1 files changed, 87 insertions, 0 deletions
diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs
new file mode 100644
index 0000000..9857557
--- /dev/null
+++ b/hsm-cam/Hsm/Cam.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.Cam
+  ( Cam
+  , stillCapture
+  , runCam
+  )
+where
+
+import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
+import Control.Monad (void)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static
+  ( SideEffects (WithSideEffects)
+  , StaticRep
+  , evalStaticRep
+  , getStaticRep
+  , unsafeEff_
+  )
+import Effectful.Resource (Resource, allocateEff, allocateEff_)
+import Foreign.C.String (peekCString)
+import Foreign.Ptr (freeHaskellFunPtr)
+import Hsm.Cam.FFI
+  ( initializeFFI
+  , makeCallback
+  , makeLogger
+  , registerCallback
+  , registerLogger
+  , requestCapture
+  , shutdownFFI
+  )
+import Hsm.Log (Log, Severity (Info, Trace), getLoggerIO, logMsg)
+
+data Cam (a :: * -> *) (b :: *)
+
+type instance DispatchOf Cam = Static WithSideEffects
+
+newtype instance StaticRep Cam
+  = Cam (MVar Int)
+
+stillCapture :: (Log "cam" :> es, Cam :> es) => Eff es ()
+stillCapture = do
+  Cam fdVar <- getStaticRep
+  logMsg Trace "Requesting still capture"
+  fd <- unsafeEff_ $ requestCapture >> takeMVar fdVar
+  logMsg Trace $ "Still capture data available in FD " <> show fd
+
+runCam
+  :: (IOE :> es, Log "cam" :> es, Resource :> es)
+  => Eff (Cam : es) a
+  -> Eff es a
+runCam action = do
+  fdVar <- liftIO newEmptyMVar
+  void loggerBracket
+  void $ requestCallbackBracket fdVar
+  void ffiBracket
+  evalStaticRep (Cam fdVar) action
+  where
+    loggerBracket = allocateEff loggerAlloc loggerDealloc
+      where
+        loggerAlloc = do
+          logMsg Info "Registering FFI logger"
+          loggerIO <- getLoggerIO
+          loggerFFI <-
+            liftIO . makeLogger $ \severity message ->
+              peekCString message >>= loggerIO (toEnum severity)
+          liftIO $ registerLogger loggerFFI
+          return loggerFFI
+        loggerDealloc loggerFFI = do
+          logMsg Info "Unregistering FFI logger"
+          liftIO $ freeHaskellFunPtr loggerFFI
+    requestCallbackBracket fdVar =
+      allocateEff requestCallbackAlloc requestCallbackDealloc
+      where
+        requestCallbackAlloc = do
+          logMsg Info "Registering FFI callback"
+          requestCallbackFFI <- liftIO . makeCallback $ putMVar fdVar
+          liftIO $ registerCallback requestCallbackFFI
+          return requestCallbackFFI
+        requestCallbackDealloc requestCallbackFFI = do
+          logMsg Info "Unregistering FFI callback"
+          liftIO $ freeHaskellFunPtr requestCallbackFFI
+    ffiBracket = allocateEff_ ffiAlloc ffiDealloc
+      where
+        ffiAlloc = liftIO initializeFFI
+        ffiDealloc = liftIO shutdownFFI