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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Hsm.Cam
( Cam
, capturePng
, runCam
)
where
import Codec.Picture (Image (Image), encodePng)
import Codec.Picture.Types (PixelRGB8)
import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (mask_)
import Control.Monad.Extra (whenM)
import Control.Monad.Loops (iterateM_)
import Data.Bits ((.|.))
import Data.ByteString.Lazy (ByteString)
import Data.List ((!?))
import Data.Primitive.Ptr (readOffPtr)
import Data.Vector.Storable (generateM)
import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket, bracket_)
import Foreign.C.String (peekCString)
import Foreign.C.Types (CSize (CSize))
import Foreign.Ptr (Ptr, castPtr, freeHaskellFunPtr, nullPtr)
import Hsm.Cam.FFI
( acquireCamera
, allocateFrameBuffer
, createRequest
, frameHeight
, frameWidth
, freeFrameBuffer
, getDmaBufferFd
, makeLogger
, makeRequestCallback
, registerLogger
, registerRequestCallback
, releaseCamera
, requestFrame
, startCamera
, startCameraManager
, stopCamera
, stopCameraManager
)
import Hsm.Core.Bracket (bracketConst, bracketLiftIO_)
import Hsm.Log (Log, Severity (Attention, Info, Trace), getLevel, logMsg, makeLoggerIO)
import MMAP (mapShared, mkMmapFlags, mmap, munmap, protRead)
import System.Directory (doesFileExist, removeFile)
import System.Environment (setEnv)
import System.IO (IOMode (ReadWriteMode), hGetLine, withFile)
import System.Posix.Files (createNamedPipe, ownerReadMode, ownerWriteMode)
import Text.Read (readMaybe)
data Cam (a :: * -> *) (b :: *)
type instance DispatchOf Cam = Static WithSideEffects
data Rep = Rep
{ requestCallbackMVar :: MVar ()
, dmaBuffer :: Ptr ()
}
newtype instance StaticRep Cam
= Cam Rep
-- RGB888 configuration for ov5647 sensor (Raspberry Pi Camera Module)
-- The following constants must be updated if either:
-- - Pixel format changes (e.g., to BGR, YUV, etc.)
-- - Camera module is replaced
frameLine :: Int
frameLine = frameWidth * 3
frameStride :: Int
frameStride = frameLine + 32
frameBufferLength :: Int
frameBufferLength = frameStride * frameHeight + 3072
capturePng :: (Log "cam" :> es, Cam :> es) => Eff es ByteString
capturePng = do
Cam Rep{..} <- getStaticRep
logMsg Trace "Requesting frame"
unsafeEff_ . mask_ $ requestFrame >> takeMVar requestCallbackMVar
logMsg Trace "Processing frame data"
pixelVector <- unsafeEff_ . generateM (frameLine * frameHeight) $ mapPixel dmaBuffer
logMsg Trace "Encoding PNG"
return . encodePng $ Image @PixelRGB8 frameWidth frameHeight pixelVector
where
mapPixel dmaBuffer index = readOffPtr (castPtr dmaBuffer) offset
where
yIndex = index `div` frameLine
xIndex = index `mod` frameLine
offset = yIndex * frameStride + xIndex
-- Bidirectional mapping between libcamera's logging system and application logs.
-- All libcamera warnings and errors are elevated to the application's
-- 'Attention' level to ensure visibility.
data LibCameraSeverity
= DEBUG
| INFO
| WARN
| ERROR
| FATAL
deriving (Read, Show)
toLibCameraSeverity :: Severity -> LibCameraSeverity
toLibCameraSeverity =
\case
Trace -> DEBUG
Info -> INFO
Attention -> WARN
fromLibCameraSeverity :: LibCameraSeverity -> Severity
fromLibCameraSeverity =
\case
DEBUG -> Trace
INFO -> Info
_ -> Attention
runCam :: (IOE :> es, Log "cam" :> es, Log "libcamera" :> es) => Eff (Cam : es) a -> Eff es a
runCam action = do
requestCallbackMVar <- liftIO newEmptyMVar
bracketConst loggerAlloc loggerDealloc
. bracketConst (requestCallbackAlloc requestCallbackMVar) requestCallbackDealloc
. bracket_ logCaptureAlloc logCaptureDealloc
. bracketLiftIO_ startCameraManager stopCameraManager
. bracketLiftIO_ acquireCamera releaseCamera
. bracketLiftIO_ allocateFrameBuffer freeFrameBuffer
. bracketLiftIO_ startCamera stopCamera
. bracketLiftIO_ createRequest (return ())
. bracket mapDmaBuffer unmapDmaBuffer
$ \dmaBuffer -> evalStaticRep (Cam Rep{..}) action
where
loggerAlloc = do
logMsg @"cam" Info "Registering FFI logger"
loggerIO <- makeLoggerIO @"cam"
loggerFFI <- liftIO . makeLogger $ \severity message -> peekCString message >>= loggerIO (toEnum severity)
liftIO $ registerLogger loggerFFI
return loggerFFI
loggerDealloc loggerFFI = do
logMsg @"cam" Info "Unregistering FFI logger"
liftIO $ freeHaskellFunPtr loggerFFI
requestCallbackAlloc requestCallbackMVar = do
logMsg @"cam" Info "Registering FFI request callback"
requestCallbackFFI <- liftIO . makeRequestCallback $ putMVar requestCallbackMVar ()
liftIO $ registerRequestCallback requestCallbackFFI
return requestCallbackFFI
requestCallbackDealloc requestCallbackFFI = do
logMsg @"cam" Info "Unregistering FFI request callback"
liftIO $ freeHaskellFunPtr requestCallbackFFI
-- We use a named pipe (FIFO) to intercept libcamera's log output. The environment
-- variables `LIBCAMERA_LOG_FILE` and `LIBCAMERA_LOG_LEVELS` configure libcamera
-- to write logs to the FIFO with appropriate severity filtering.
--
-- A dedicated thread reads from the FIFO, parses log severity levels, and
-- forwards messages to the application's logger with proper level mapping.
logCaptureFifo = "/tmp/hsm-cam-libcamera.fifo"
logCaptureClear = liftIO . whenM (doesFileExist logCaptureFifo) $ removeFile logCaptureFifo
logCaptureSetEnvVar key value = do
logMsg @"cam" Info $ "Setting env variable: " <> key <> "=" <> value
liftIO $ setEnv key value
logCaptureAlloc = do
logCaptureClear
logMsg @"cam" Info $ "Creating libcamera log capture FIFO at: " <> logCaptureFifo
liftIO . createNamedPipe logCaptureFifo $ ownerReadMode .|. ownerWriteMode
libCameraSeverity <- toLibCameraSeverity <$> getLevel @"libcamera"
logCaptureSetEnvVar "LIBCAMERA_LOG_FILE" logCaptureFifo
logCaptureSetEnvVar "LIBCAMERA_LOG_LEVELS" $ "*:" <> show libCameraSeverity
loggerIO <- makeLoggerIO @"libcamera"
logMsg @"cam" Info "Starting libcamera log capture"
-- Thread handles multiline logs by maintaining severity state between lines.
-- When a new line doesn't contain a parsable severity level, the previous
-- line's level is reused to ensure continuous log context.
liftIO . forkIO . withFile logCaptureFifo ReadWriteMode $ \handle ->
flip iterateM_ DEBUG $ \previousSeverity -> do
logLine <- hGetLine handle
flip (maybe $ return previousSeverity) (words logLine !? 2 >>= readMaybe) $ \severity -> do
loggerIO (fromLibCameraSeverity severity) logLine
return severity
logCaptureDealloc = do
logMsg @"cam" Info "Removing libcamera log capture FIFO"
logCaptureClear
-- Memory maps the camera's DMA buffer for frame access
mapSize = CSize $ toEnum frameBufferLength
mapFlags = mkMmapFlags mapShared mempty
mapDmaBuffer = do
logMsg @"cam" Info "Mapping DMA buffer"
liftIO $ getDmaBufferFd >>= \dmaBufferFd -> mmap nullPtr mapSize protRead mapFlags dmaBufferFd 0
unmapDmaBuffer dmaBuffer = do
logMsg @"cam" Info "Unmapping DMA buffer"
liftIO $ munmap dmaBuffer mapSize
|
