diff options
Diffstat (limited to 'hsm-cam/Hsm')
| -rw-r--r-- | hsm-cam/Hsm/Cam.hs | 163 | ||||
| -rw-r--r-- | hsm-cam/Hsm/Cam/FFI.hs | 21 |
2 files changed, 118 insertions, 66 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 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 |