aboutsummaryrefslogtreecommitdiff
path: root/hsm-cam/Hsm
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-cam/Hsm')
-rw-r--r--hsm-cam/Hsm/Cam.hs127
-rw-r--r--hsm-cam/Hsm/Cam/FFI.hs71
2 files changed, 137 insertions, 61 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
diff --git a/hsm-cam/Hsm/Cam/FFI.hs b/hsm-cam/Hsm/Cam/FFI.hs
index 93d2f57..1c37fac 100644
--- a/hsm-cam/Hsm/Cam/FFI.hs
+++ b/hsm-cam/Hsm/Cam/FFI.hs
@@ -1,36 +1,73 @@
{-# LANGUAGE CApiFFI #-}
module Hsm.Cam.FFI
- ( makeLogger
+ ( frameStride
+ , frameBufferLength
+ , frameWidth
+ , frameHeight
+ , frameLine
+ , makeLogger
, registerLogger
, makeCallback
, registerCallback
- , initializeFFI
- , shutdownFFI
- , requestCapture
- )
-where
+ , startCameraManager
+ , stopCameraManager
+ , acquireCamera
+ , releaseCamera
+ , allocateFrameBuffer
+ , freeFrameBuffer
+ , startCamera
+ , stopCamera
+ , createRequest
+ , getDmaBufferFd
+ , requestFrame
+ ) where
import Foreign.C.String (CString)
+import Foreign.C.Types (CInt(CInt))
import Foreign.Ptr (FunPtr)
+import System.Posix.Types (Fd(Fd))
type Logger = Int -> CString -> IO ()
-type Callback = Int -> IO ()
+type Callback = IO ()
-foreign import ccall safe "wrapper" makeLogger :: Logger -> IO (FunPtr Logger)
+foreign import capi unsafe "Cam.hpp value FRAME_WIDTH" frameWidth :: Int
-foreign import capi safe "Cam.hpp register_logger"
- registerLogger :: FunPtr Logger -> IO ()
+foreign import capi unsafe "Cam.hpp value FRAME_HEIGHT" frameHeight :: Int
-foreign import ccall safe "wrapper"
- makeCallback :: Callback -> IO (FunPtr Callback)
+foreign import capi unsafe "Cam.hpp value FRAME_LINE" frameLine :: Int
-foreign import capi safe "Cam.hpp register_callback"
- registerCallback :: FunPtr Callback -> IO ()
+foreign import capi unsafe "Cam.hpp value FRAME_STRIDE" frameStride :: Int
-foreign import capi safe "Cam.hpp initialize_ffi" initializeFFI :: IO ()
+foreign import capi unsafe "Cam.hpp value FRAME_BUFFER_LENGTH" frameBufferLength :: Int
-foreign import capi safe "Cam.hpp shutdown_ffi" shutdownFFI :: IO ()
+foreign import ccall unsafe "wrapper" makeLogger :: Logger -> IO (FunPtr Logger)
-foreign import capi safe "Cam.hpp request_capture" requestCapture :: IO ()
+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 safe "Cam.hpp register_callback" registerCallback :: FunPtr Callback -> IO ()
+
+foreign import ccall safe "Cam.hpp start_camera_manager" startCameraManager :: IO Int
+
+foreign import ccall safe "Cam.hpp stop_camera_manager" stopCameraManager :: IO ()
+
+foreign import ccall safe "Cam.hpp acquire_camera" acquireCamera :: IO Int
+
+foreign import ccall safe "Cam.hpp release_camera" releaseCamera :: IO ()
+
+foreign import ccall safe "Cam.hpp allocate_frame_buffer" allocateFrameBuffer :: IO Int
+
+foreign import ccall safe "Cam.hpp free_frame_buffer" freeFrameBuffer :: IO ()
+
+foreign import ccall safe "Cam.hpp start_camera" startCamera :: IO Int
+
+foreign import ccall safe "Cam.hpp stop_camera" stopCamera :: IO ()
+
+foreign import ccall safe "Cam.hpp create_request" createRequest :: IO Int
+
+foreign import ccall safe "Cam.hpp get_dma_buffer_fd" getDmaBufferFd :: IO Fd
+
+foreign import ccall safe "Cam.hpp request_frame" requestFrame :: IO ()
powered by cgit v1.2.1, back to main portfolio site