2 files changed, 276 insertions, 0 deletions
diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs
new file mode 100644
index 0000000..d1f9cd2
--- /dev/null
+++ b/hsm-cam/Hsm/Cam.hs
@@ -0,0 +1,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
diff --git a/hsm-cam/Hsm/Cam/FFI.hsc b/hsm-cam/Hsm/Cam/FFI.hsc
new file mode 100644
index 0000000..6c5dd3d
--- /dev/null
+++ b/hsm-cam/Hsm/Cam/FFI.hsc
@@ -0,0 +1,82 @@
+{-# LANGUAGE CApiFFI #-}
+
+module Hsm.Cam.FFI
+  ( frameWidth
+  , frameHeight
+  , makeLogger
+  , registerLogger
+  , makeRequestCallback
+  , registerRequestCallback
+  , startCameraManager
+  , stopCameraManager
+  , acquireCamera
+  , releaseCamera
+  , allocateFrameBuffer
+  , freeFrameBuffer
+  , startCamera
+  , stopCamera
+  , createRequest
+  , getDmaBufferFd
+  , requestFrame
+  )
+where
+
+import Foreign.C.String (CString)
+import Foreign.C.Types (CInt (CInt))
+import Foreign.Ptr (FunPtr)
+import System.Posix.Types (Fd (Fd))
+
+type Logger = Int -> CString -> IO ()
+
+type RequestCallback = IO ()
+
+foreign import capi safe "Cam.hpp value FRAME_WIDTH"
+  frameWidth :: Int
+
+foreign import capi safe "Cam.hpp value FRAME_HEIGHT"
+  frameHeight :: Int
+
+foreign import ccall safe "wrapper"
+  makeLogger :: Logger -> IO (FunPtr Logger)
+
+foreign import capi safe "Cam.hpp register_logger"
+  registerLogger :: FunPtr Logger -> IO ()
+
+foreign import ccall safe "wrapper"
+  makeRequestCallback :: RequestCallback -> IO (FunPtr RequestCallback)
+
+foreign import capi safe "Cam.hpp register_request_callback"
+  registerRequestCallback :: FunPtr RequestCallback -> IO ()
+
+foreign import capi safe "Cam.hpp start_camera_manager"
+  startCameraManager :: IO ()
+
+foreign import capi safe "Cam.hpp stop_camera_manager"
+  stopCameraManager :: IO ()
+
+foreign import capi safe "Cam.hpp acquire_camera"
+  acquireCamera :: IO ()
+
+foreign import capi safe "Cam.hpp release_camera"
+  releaseCamera :: IO ()
+
+foreign import capi safe "Cam.hpp allocate_frame_buffer"
+  allocateFrameBuffer :: IO ()
+
+foreign import capi safe "Cam.hpp free_frame_buffer"
+  freeFrameBuffer :: IO ()
+
+foreign import capi safe "Cam.hpp start_camera"
+  startCamera :: IO ()
+
+foreign import capi safe "Cam.hpp stop_camera"
+  stopCamera :: IO ()
+
+foreign import capi safe "Cam.hpp create_request"
+  createRequest :: IO ()
+
+foreign import capi safe "Cam.hpp get_dma_buffer_fd"
+  getDmaBufferFd :: IO Fd
+
+foreign import capi safe "Cam.hpp request_frame"
+  requestFrame :: IO ()