diff options
Diffstat (limited to 'hsm-cam/Hsm/Cam.hs')
| -rw-r--r-- | hsm-cam/Hsm/Cam.hs | 127 |
1 files changed, 83 insertions, 44 deletions
diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs index 78a3e25..8300ae7 100644 --- a/hsm-cam/Hsm/Cam.hs +++ b/hsm-cam/Hsm/Cam.hs @@ -1,61 +1,86 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Hsm.Cam ( Cam - , stillCapture + , capturePng , runCam - ) -where + ) where +import Codec.Picture (Image(Image), encodePng) +import Codec.Picture.Types (PixelRGB8) import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar) -import Control.Monad (void) -import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>)) -import Effectful.Dispatch.Static - ( SideEffects (WithSideEffects) - , StaticRep - , evalStaticRep - , getStaticRep - , unsafeEff_ - ) -import Effectful.Resource (Resource, allocateEff, allocateEff_) +import Control.Exception (mask_) +import Data.ByteString.Lazy (ByteString) +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.Ptr (freeHaskellFunPtr) +import Foreign.C.Types (CSize(CSize)) +import Foreign.Ptr (Ptr, castPtr, freeHaskellFunPtr, nullPtr) import Hsm.Cam.FFI - ( initializeFFI + ( acquireCamera + , allocateFrameBuffer + , createRequest + , frameBufferLength + , frameHeight + , frameLine + , frameStride + , frameWidth + , freeFrameBuffer + , getDmaBufferFd , makeCallback , makeLogger , registerCallback , registerLogger - , requestCapture - , shutdownFFI + , releaseCamera + , requestFrame + , startCamera + , startCameraManager + , stopCamera + , stopCameraManager ) -import Hsm.Log (Log, Severity (Info, Trace), getLoggerIO, logMsg) +import Hsm.Log (Log, Severity(Info, Trace), getLoggerIO, logMsg) +import MMAP (mapShared, mkMmapFlags, mmap, munmap, protRead) data Cam (a :: * -> *) (b :: *) type instance DispatchOf Cam = Static WithSideEffects -newtype instance StaticRep Cam - = Cam (MVar Int) +data Rep = Rep + { callbackMVar :: MVar () + , dmaBuffer :: Ptr () + } + +newtype instance StaticRep Cam = + Cam Rep -stillCapture :: (Log "cam" :> es, Cam :> es) => Eff es () -stillCapture = do - Cam fdVar <- getStaticRep - logMsg Trace "Requesting still capture" - fd <- unsafeEff_ $ requestCapture >> takeMVar fdVar - logMsg Trace $ "Still capture data available in FD " <> show fd +capturePng :: (Log "cam" :> es, Cam :> es) => Eff es ByteString +capturePng = do + Cam Rep {..} <- getStaticRep + logMsg Trace "Requesting frame" + unsafeEff_ . mask_ $ requestFrame >> takeMVar callbackMVar + 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 -runCam - :: (IOE :> es, Log "cam" :> es, Resource :> es) => Eff (Cam : es) a -> Eff es a +runCam :: (IOE :> es, Log "cam" :> es) => Eff (Cam : es) a -> Eff es a runCam action = do - fdVar <- liftIO newEmptyMVar - void loggerBracket - void $ requestCallbackBracket fdVar - void ffiBracket - evalStaticRep (Cam fdVar) action + callbackMVar <- liftIO newEmptyMVar + loggerBracket . callbackBracket callbackMVar . cameraManagerBracket . cameraAcquireBracket . frameBufferBracket . cameraStartBracket . createRequestBracket . mmapBracket $ \dmaBuffer -> do + evalStaticRep (Cam Rep {..}) action where - loggerBracket = allocateEff loggerAlloc loggerDealloc + loggerBracket = bracket loggerAlloc loggerDealloc . const where loggerAlloc = do logMsg Info "Registering FFI logger" @@ -66,17 +91,31 @@ runCam action = do loggerDealloc loggerFFI = do logMsg Info "Unregistering FFI logger" liftIO $ freeHaskellFunPtr loggerFFI - requestCallbackBracket fdVar = allocateEff requestCallbackAlloc requestCallbackDealloc + callbackBracket callbackMVar = bracket callbackAlloc callbackDealloc . const where - requestCallbackAlloc = do + callbackAlloc = do logMsg Info "Registering FFI callback" - requestCallbackFFI <- liftIO . makeCallback $ putMVar fdVar - liftIO $ registerCallback requestCallbackFFI - return requestCallbackFFI - requestCallbackDealloc requestCallbackFFI = do + callbackFFI <- liftIO . makeCallback $ putMVar callbackMVar () + liftIO $ registerCallback callbackFFI + return callbackFFI + callbackDealloc callbackFFI = do logMsg Info "Unregistering FFI callback" - liftIO $ freeHaskellFunPtr requestCallbackFFI - ffiBracket = allocateEff_ ffiAlloc ffiDealloc + 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 () + -- Memory maps the camera's DMA buffer for frame access + mmapBracket = bracket mmapDmaBuffer munmapDmaBuffer where - ffiAlloc = liftIO initializeFFI - ffiDealloc = liftIO shutdownFFI + 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 |