Improves `hsm-cam`

- Moves C++ constants to Haskell side
- Uses better names for request callback related variables
- Captures and redirects libcamera's internal logging

1 files changed, 112 insertions, 51 deletions

diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs
index f894bc3..c82cdd7 100644
--- a/hsm-cam/Hsm/Cam.hs
+++ b/hsm-cam/Hsm/Cam.hs
@@ -10,9 +10,13 @@ module Hsm.Cam
 
 import Codec.Picture (Image(Image), encodePng)
 import Codec.Picture.Types (PixelRGB8)
-import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar)
+import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar)
 import Control.Exception (mask_)
+import Control.Monad (forever)
+import Control.Monad.Loops (whileM_)
+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)
@@ -25,17 +29,14 @@ import Hsm.Cam.FFI
   ( acquireCamera
   , allocateFrameBuffer
   , createRequest
-  , frameBufferLength
   , frameHeight
-  , frameLine
-  , frameStride
   , frameWidth
   , freeFrameBuffer
   , getDmaBufferFd
-  , makeCallback
   , makeLogger
-  , registerCallback
+  , makeRequestCallback
   , registerLogger
+  , registerRequestCallback
   , releaseCamera
   , requestFrame
   , startCamera
@@ -43,26 +44,44 @@ import Hsm.Cam.FFI
   , stopCamera
   , stopCameraManager
   )
-import Hsm.Log (Log, Severity(Info, Trace), logMsg, makeLoggerIO)
+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
-  { callbackMVar :: MVar ()
+  { 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 callbackMVar
+  unsafeEff_ . mask_ $ requestFrame >> takeMVar requestCallbackMVar
   logMsg Trace "Processing frame data"
   pixelVector <- unsafeEff_ . generateM (frameLine * frameHeight) $ mapPixel dmaBuffer
   logMsg Trace "Encoding PNG"
@@ -74,48 +93,90 @@ capturePng = do
         xIndex = index `mod` frameLine
         offset = yIndex * frameStride + xIndex
 
-runCam :: (IOE :> es, Log "cam" :> es) => Eff (Cam : es) a -> Eff es a
+-- 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 Trace = DEBUG
+toLibCameraSeverity Info = INFO
+toLibCameraSeverity Attention = WARN
+
+fromLibCameraSeverity :: LibCameraSeverity -> Severity
+fromLibCameraSeverity DEBUG = Trace
+fromLibCameraSeverity INFO = Info
+fromLibCameraSeverity _ = Attention
+
+runCam :: (IOE :> es, Log "cam" :> es, Log "libcamera" :> es) => Eff (Cam : es) a -> Eff es a
 runCam action = do
-  callbackMVar <- liftIO newEmptyMVar
-  loggerBracket . callbackBracket callbackMVar . cameraManagerBracket . cameraAcquireBracket . frameBufferBracket . cameraStartBracket . createRequestBracket . mmapBracket $ \dmaBuffer -> do
-    evalStaticRep (Cam Rep {..}) action
+  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
-    loggerBracket = bracket loggerAlloc loggerDealloc . const
-      where
-        loggerAlloc = do
-          logMsg Info "Registering FFI logger"
-          loggerIO <- makeLoggerIO
-          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
-    callbackBracket callbackMVar = bracket callbackAlloc callbackDealloc . const
-      where
-        callbackAlloc = do
-          logMsg Info "Registering FFI callback"
-          callbackFFI <- liftIO . makeCallback $ putMVar callbackMVar ()
-          liftIO $ registerCallback callbackFFI
-          return callbackFFI
-        callbackDealloc callbackFFI = do
-          logMsg Info "Unregistering FFI callback"
-          liftIO $ freeHaskellFunPtr callbackFFI
-    -- Convenience wrappers for specific libcamera resources
-    bracketFFI alloc dealloc = bracket_ (liftIO alloc) (liftIO dealloc)
-    cameraManagerBracket = bracketFFI startCameraManager stopCameraManager
-    cameraAcquireBracket = bracketFFI acquireCamera releaseCamera
-    frameBufferBracket = bracketFFI allocateFrameBuffer freeFrameBuffer
-    cameraStartBracket = bracketFFI startCamera stopCamera
-    createRequestBracket = bracketFFI createRequest $ return ()
+    bracketConst alloc dealloc = bracket alloc dealloc . const
+    bracketLiftIO_ alloc dealloc = bracket_ (liftIO alloc) (liftIO dealloc)
+    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 . whileM_ (doesFileExist logCaptureFifo) $ removeFile logCaptureFifo
+    logCaptureSetEnvVar key value = do
+      logMsg @"cam" Info $ "Setting env variable: " <> key <> "=" <> value
+      liftIO $ setEnv key value
+    logCaptureLineSeverity logLine = maybe Trace fromLibCameraSeverity $ words logLine !? 2 >>= readMaybe
+    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"
+      liftIO . forkIO . withFile logCaptureFifo ReadWriteMode $ \handle -> forever $ hGetLine handle >>= \logLine -> loggerIO (logCaptureLineSeverity logLine) logLine
+    logCaptureDealloc = do
+      logMsg @"cam" Info "Removing libcamera log capture FIFO"
+      logCaptureClear
     -- Memory maps the camera's DMA buffer for frame access
-    mmapBracket = bracket mmapDmaBuffer munmapDmaBuffer
-      where
-        mmapSize = CSize $ toEnum frameBufferLength
-        mmapFlags = mkMmapFlags mapShared mempty
-        mmapDmaBuffer = do
-          logMsg Info "Mapping DMA buffer"
-          liftIO $ getDmaBufferFd >>= \dmaBufferFd -> mmap nullPtr mmapSize protRead mmapFlags dmaBufferFd 0
-        munmapDmaBuffer dmaBuffer = do
-          logMsg Info "Unmapping DMA buffer"
-          liftIO $ munmap dmaBuffer mmapSize
+    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