From 62fce45039b0b8ab3d9d42b69a000fec00e1d35e Mon Sep 17 00:00:00 2001 From: Paul Oliver Date: Fri, 2 Jan 2026 05:53:10 +0000 Subject: Removes hsm-cam --- hsm-cam/Hsm/Cam.hs | 194 ----------------------------------------------------- 1 file changed, 194 deletions(-) delete mode 100644 hsm-cam/Hsm/Cam.hs (limited to 'hsm-cam/Hsm/Cam.hs') diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs deleted file mode 100644 index dfa7425..0000000 --- a/hsm-cam/Hsm/Cam.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# 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, Logs, 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, Logs '["cam", "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 -- cgit v1.2.1