1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
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
|
