Improves `hsm-cam`

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

7 files changed, 143 insertions, 93 deletions

diff --git a/hsm-cam/FFI/Cam.cpp b/hsm-cam/FFI/Cam.cpp
index 9e371c1..bfdecf6 100644
--- a/hsm-cam/FFI/Cam.cpp
+++ b/hsm-cam/FFI/Cam.cpp
@@ -8,7 +8,7 @@ using namespace libcamera;
 using namespace std;
 
 HsLogger g_logger;
-HsCallback g_callback;
+HsRequestCallback g_request_callback;
 unique_ptr<CameraManager> g_manager;
 shared_ptr<Camera> g_camera;
 unique_ptr<CameraConfiguration> g_config;
@@ -23,11 +23,11 @@ logMsg(Severity severity, const format_string<Args...> fmt, const Args &...args)
 }
 
 void
-request_complete(Request *request)
+internal_request_callback(Request *request)
 {
     int sequence = request->buffers().begin()->second->metadata().sequence;
     logMsg(Trace, "Completed request #{}", sequence);
-    g_callback();
+    g_request_callback();
 }
 
 extern "C" void
@@ -38,10 +38,10 @@ register_logger(HsLogger hs_logger)
 }
 
 extern "C" void
-register_callback(HsCallback hs_callback)
+register_request_callback(HsRequestCallback hs_request_callback)
 {
-    g_callback = hs_callback;
-    logMsg(Info, "Registered FFI callback");
+    g_request_callback = hs_request_callback;
+    logMsg(Info, "Registered FFI request callback");
 }
 
 extern "C" void
@@ -91,8 +91,8 @@ allocate_frame_buffer()
     g_allocator = make_unique<FrameBufferAllocator>(g_camera);
     g_allocator->allocate(g_config->at(0).stream());
 
-    logMsg(Info, "Registering request complete callback");
-    g_camera->requestCompleted.connect(request_complete);
+    logMsg(Info, "Registering internal request callback");
+    g_camera->requestCompleted.connect(internal_request_callback);
 }
 
 extern "C" void
diff --git a/hsm-cam/FFI/Cam.hpp b/hsm-cam/FFI/Cam.hpp
index 374e16a..eeea814 100644
--- a/hsm-cam/FFI/Cam.hpp
+++ b/hsm-cam/FFI/Cam.hpp
@@ -1,15 +1,8 @@
 #ifndef CAM_HPP
 #define CAM_HPP
 
-// RGB888 configuration for ov5647 sensor (Raspberry Pi Camera Module)
-// Must be updated if either:
-// - Pixel format changes (e.g., to BGR, YUV, etc.)
-// - Camera module is replaced
 #define FRAME_WIDTH (800)
 #define FRAME_HEIGHT (600)
-#define FRAME_LINE (FRAME_WIDTH * 3)
-#define FRAME_STRIDE (FRAME_LINE + 32)
-#define FRAME_BUFFER_LENGTH (FRAME_STRIDE * FRAME_HEIGHT + 3072)
 
 enum Severity
 {
@@ -19,14 +12,14 @@ enum Severity
 };
 
 typedef void (*HsLogger)(enum Severity, const char *);
-typedef void (*HsCallback)();
+typedef void (*HsRequestCallback)();
 
 #ifdef __cplusplus
 extern "C"
 {
 #endif
     void register_logger(HsLogger hs_logger);
-    void register_callback(HsCallback hs_callback);
+    void register_request_callback(HsRequestCallback hs_request_callback);
     void start_camera_manager();
     void stop_camera_manager();
     void acquire_camera();
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
diff --git a/hsm-cam/Hsm/Cam/FFI.hs b/hsm-cam/Hsm/Cam/FFI.hs
index 1c37fac..6ee648d 100644
--- a/hsm-cam/Hsm/Cam/FFI.hs
+++ b/hsm-cam/Hsm/Cam/FFI.hs
@@ -1,15 +1,12 @@
 {-# LANGUAGE CApiFFI #-}
 
 module Hsm.Cam.FFI
-  ( frameStride
-  , frameBufferLength
-  , frameWidth
+  ( frameWidth
   , frameHeight
-  , frameLine
   , makeLogger
   , registerLogger
-  , makeCallback
-  , registerCallback
+  , makeRequestCallback
+  , registerRequestCallback
   , startCameraManager
   , stopCameraManager
   , acquireCamera
@@ -30,25 +27,19 @@ import System.Posix.Types (Fd(Fd))
 
 type Logger = Int -> CString -> IO ()
 
-type Callback = IO ()
+type RequestCallback = IO ()
 
 foreign import capi unsafe "Cam.hpp value FRAME_WIDTH" frameWidth :: Int
 
 foreign import capi unsafe "Cam.hpp value FRAME_HEIGHT" frameHeight :: Int
 
-foreign import capi unsafe "Cam.hpp value FRAME_LINE" frameLine :: Int
-
-foreign import capi unsafe "Cam.hpp value FRAME_STRIDE" frameStride :: Int
-
-foreign import capi unsafe "Cam.hpp value FRAME_BUFFER_LENGTH" frameBufferLength :: Int
-
 foreign import ccall unsafe "wrapper" makeLogger :: Logger -> IO (FunPtr Logger)
 
 foreign import ccall safe "Cam.hpp register_logger" registerLogger :: FunPtr Logger -> IO ()
 
-foreign import ccall unsafe "wrapper" makeCallback :: Callback -> IO (FunPtr Callback)
+foreign import ccall unsafe "wrapper" makeRequestCallback :: RequestCallback -> IO (FunPtr RequestCallback)
 
-foreign import ccall safe "Cam.hpp register_callback" registerCallback :: FunPtr Callback -> IO ()
+foreign import ccall safe "Cam.hpp register_request_callback" registerRequestCallback :: FunPtr RequestCallback -> IO ()
 
 foreign import ccall safe "Cam.hpp start_camera_manager" startCameraManager :: IO Int
 
diff --git a/hsm-cam/Test/Cam.hs b/hsm-cam/Test/Cam.hs
index 9b06785..fc56b6c 100644
--- a/hsm-cam/Test/Cam.hs
+++ b/hsm-cam/Test/Cam.hs
@@ -1,16 +1,11 @@
 import Control.Monad (forM_)
 import Data.ByteString.Lazy (writeFile)
-import Data.Function ((&))
 import Effectful (liftIO, runEff)
 import Hsm.Cam (capturePng, runCam)
-import Hsm.Log (Severity(Info, Trace), logMsg, runLog)
+import Hsm.Log (Severity(Info, Trace), runLog)
 import Prelude hiding (writeFile)
 
 main :: IO ()
-main = forM_ [0 .. 31] savePng & runCam & runLog @"cam" Trace & runEff
-  where
-    savePng index = do
-      logMsg Info $ "Saving image to file: " <> path
-      capturePng >>= liftIO . writeFile path
-      where
-        path = "/tmp/hsm-cam-test" <> show @Int index <> ".png"
+main =
+  runEff . runLog @"cam" Trace . runLog @"libcamera" Info . runCam . forM_ [0 .. 31] $ \index ->
+    capturePng >>= liftIO . writeFile ("/tmp/hsm-cam-test" <> show @Int index <> ".png")
diff --git a/hsm-cam/hsm-cam.cabal b/hsm-cam/hsm-cam.cabal
index ade45d9..5c06ea7 100644
--- a/hsm-cam/hsm-cam.cabal
+++ b/hsm-cam/hsm-cam.cabal
@@ -10,12 +10,15 @@ library
   build-depends:
     , base
     , bytestring
+    , directory
     , effectful-core
     , effectful-plugin
     , hsm-log
     , JuicyPixels
+    , monad-loops
     , primitive
     , shared-memory
+    , unix
     , vector
 
   cxx-options:      -O3 -Wall -Wextra -Werror -std=c++20
@@ -38,12 +41,15 @@ executable test-cam
   build-depends:
     , base
     , bytestring
+    , directory
     , effectful-core
     , effectful-plugin
     , hsm-log
     , JuicyPixels
+    , monad-loops
     , primitive
     , shared-memory
+    , unix
     , vector
 
   cxx-options:      -O3 -Wall -Wextra -Werror -std=c++20
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index d8dbab0..570b19a 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -5,6 +5,7 @@
 module Hsm.Log
   ( Severity(Attention, Info, Trace)
   , Log
+  , getLevel
   , makeLoggerIO
   , logMsg
   , logBlock
@@ -37,10 +38,13 @@ type instance DispatchOf (Log d) = Static WithSideEffects
 newtype instance StaticRep (Log d) =
   Log Severity
 
+getLevel :: Log d :> es => Eff es Severity
+getLevel = getStaticRep >>= \(Log level) -> return level
+
 makeLoggerIO ::
      forall d es. (KnownSymbol d, Log d :> es)
   => Eff es (Severity -> String -> IO ())
-makeLoggerIO = getStaticRep >>= \(Log level) -> return $ loggerIO level
+makeLoggerIO = loggerIO <$> getLevel
   where
     loggerIO level severity message =
       when (severity <= level) $ do