26 files changed, 757 insertions, 259 deletions

diff --git a/Makefile b/Makefile
index 8cb9a78..68fc7ca 100644
--- a/Makefile
+++ b/Makefile
@@ -7,8 +7,5 @@ build:
 clean:
 	stack clean --full
 
-exec:
-	stack exec $(exec)
-
 update:
 	yq -i '.resolver="$(resolver)" | .packages=[$(packages)]' stack.yaml
diff --git a/hsm-cam/FFI/Cam.cpp b/hsm-cam/FFI/Cam.cpp
index 05fd1a8..4c21e7f 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,10 +23,11 @@ logMsg(Severity severity, const format_string<Args...> fmt, const Args &...args)
 }
 
 void
-request_complete(Request *request)
+internal_request_callback(Request *request)
 {
-    logMsg(Trace, "Completed request");
-    g_callback(request->buffers().begin()->second->planes()[0].fd.get());
+    int sequence = request->buffers().begin()->second->metadata().sequence;
+    logMsg(Trace, "Completed request #{}", sequence);
+    g_request_callback();
 }
 
 extern "C" void
@@ -37,63 +38,108 @@ 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
-initialize_ffi()
+start_camera_manager()
 {
     logMsg(Info, "Starting camera manager");
     g_manager = make_unique<CameraManager>();
     g_manager->start();
+}
+
+extern "C" void
+stop_camera_manager()
+{
+    logMsg(Info, "Stopping camera manager");
+    g_manager->stop();
+}
 
+extern "C" void
+acquire_camera()
+{
     logMsg(Info, "Acquiring camera");
     g_camera = g_manager->cameras()[0];
     g_camera->acquire();
+    logMsg(Info, "Acquired camera: {}", g_camera->id());
+}
 
-    logMsg(Info, "Generating still capture configuration");
+extern "C" void
+release_camera()
+{
+    logMsg(Info, "Releasing camera");
+    g_camera->release();
+    g_camera.reset();
+}
+
+extern "C" void
+allocate_frame_buffer()
+{
+    logMsg(Info, "Generating camera configuration");
     g_config = g_camera->generateConfiguration({ StreamRole::StillCapture });
+    g_config->at(0).size.width = FRAME_WIDTH;
+    g_config->at(0).size.height = FRAME_HEIGHT;
+    g_config->at(0).pixelFormat = formats::BGR888;
+    logMsg(Info, "Generated camera configuration: {}", g_config->at(0).toString());
     g_camera->configure(g_config.get());
 
-    logMsg(Info, "Allocating buffer");
+    logMsg(Info, "Generating frame buffer allocator");
     g_allocator = make_unique<FrameBufferAllocator>(g_camera);
-    g_allocator->allocate((*g_config)[0].stream());
+    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
+free_frame_buffer()
+{
+    logMsg(Info, "Freeing frame buffer allocator");
+    g_allocator->free(g_config->at(0).stream());
+    g_allocator.reset();
+}
+
+extern "C" void
+start_camera()
+{
     logMsg(Info, "Starting camera");
     g_camera->start();
 }
 
 extern "C" void
-shutdown_ffi()
+stop_camera()
 {
     logMsg(Info, "Stopping camera");
     g_camera->stop();
+}
 
-    logMsg(Info, "Freeing frame buffer allocator");
-    g_allocator->free((*g_config)[0].stream());
-    g_allocator.reset();
+extern "C" void
+create_request()
+{
+    logMsg(Info, "Creating request");
+    g_request = g_camera->createRequest();
 
-    logMsg(Info, "Releasing camera");
-    g_camera->release();
-    g_camera.reset();
+    logMsg(Info, "Setting buffer for request");
+    Stream *stream = g_config->at(0).stream();
+    g_request->addBuffer(stream, g_allocator->buffers(stream)[0].get());
+}
 
-    logMsg(Info, "Stopping camera manager");
-    g_manager->stop();
+extern "C" int
+get_dma_buffer_fd()
+{
+    int fd = g_request->buffers().begin()->second->planes()[0].fd.get();
+    logMsg(Info, "DMA buffer available in FD {}", fd);
+    return fd;
 }
 
 extern "C" void
-request_capture()
+request_frame()
 {
-    logMsg(Trace, "Requesting still capture");
-
-    Stream *stream = (*g_config)[0].stream();
-    g_request = g_camera->createRequest();
-    g_request->addBuffer(stream, g_allocator->buffers(stream)[0].get());
+    logMsg(Trace, "Requested frame");
+    g_request->reuse(Request::ReuseBuffers);
     g_camera->queueRequest(g_request.get());
 }
diff --git a/hsm-cam/FFI/Cam.hpp b/hsm-cam/FFI/Cam.hpp
index c2cd4ed..eeea814 100644
--- a/hsm-cam/FFI/Cam.hpp
+++ b/hsm-cam/FFI/Cam.hpp
@@ -1,6 +1,9 @@
 #ifndef CAM_HPP
 #define CAM_HPP
 
+#define FRAME_WIDTH (800)
+#define FRAME_HEIGHT (600)
+
 enum Severity
 {
     Attention = 0,
@@ -9,17 +12,26 @@ enum Severity
 };
 
 typedef void (*HsLogger)(enum Severity, const char *);
-typedef void (*HsCallback)(int fd);
+typedef void (*HsRequestCallback)();
 
 #ifdef __cplusplus
 extern "C"
 {
 #endif
     void register_logger(HsLogger hs_logger);
-    void register_callback(HsCallback hs_callback);
-    void initialize_ffi();
-    void shutdown_ffi();
-    void request_capture();
+    void register_request_callback(HsRequestCallback hs_request_callback);
+    void start_camera_manager();
+    void stop_camera_manager();
+    void acquire_camera();
+    void release_camera();
+    void allocate_frame_buffer();
+    void free_frame_buffer();
+    void start_camera();
+    void stop_camera();
+    void create_request();
+
+    int get_dma_buffer_fd();
+    void request_frame();
 #ifdef __cplusplus
 }
 #endif
diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs
index 78a3e25..e5b30c2 100644
--- a/hsm-cam/Hsm/Cam.hs
+++ b/hsm-cam/Hsm/Cam.hs
@@ -1,82 +1,192 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Hsm.Cam
   ( Cam
-  , stillCapture
+  , capturePng
   , runCam
-  )
-where
+  ) where
 
-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 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.Ptr (freeHaskellFunPtr)
+import Foreign.C.Types (CSize(CSize))
+import Foreign.Ptr (Ptr, castPtr, freeHaskellFunPtr, nullPtr)
 import Hsm.Cam.FFI
-  ( initializeFFI
-  , makeCallback
+  ( acquireCamera
+  , allocateFrameBuffer
+  , createRequest
+  , frameHeight
+  , frameWidth
+  , freeFrameBuffer
+  , getDmaBufferFd
   , makeLogger
-  , registerCallback
+  , makeRequestCallback
   , registerLogger
-  , requestCapture
-  , shutdownFFI
+  , registerRequestCallback
+  , releaseCamera
+  , requestFrame
+  , startCamera
+  , startCameraManager
+  , stopCamera
+  , stopCameraManager
   )
-import Hsm.Log (Log, Severity (Info, Trace), getLoggerIO, logMsg)
+import Hsm.Core.Bracket (bracketConst, bracketLiftIO_)
+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
 
-newtype instance StaticRep Cam
-  = Cam (MVar Int)
+data Rep = Rep
+  { requestCallbackMVar :: MVar ()
+  , dmaBuffer :: Ptr ()
+  }
 
-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
+newtype instance StaticRep Cam =
+  Cam Rep
 
-runCam
-  :: (IOE :> es, Log "cam" :> es, Resource :> 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
+-- 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
-    loggerBracket = allocateEff loggerAlloc loggerDealloc
-      where
-        loggerAlloc = do
-          logMsg Info "Registering FFI logger"
-          loggerIO <- getLoggerIO
-          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
-    requestCallbackBracket fdVar = allocateEff requestCallbackAlloc requestCallbackDealloc
+    mapPixel dmaBuffer index = readOffPtr (castPtr dmaBuffer) offset
       where
-        requestCallbackAlloc = do
-          logMsg Info "Registering FFI callback"
-          requestCallbackFFI <- liftIO . makeCallback $ putMVar fdVar
-          liftIO $ registerCallback requestCallbackFFI
-          return requestCallbackFFI
-        requestCallbackDealloc requestCallbackFFI = do
-          logMsg Info "Unregistering FFI callback"
-          liftIO $ freeHaskellFunPtr requestCallbackFFI
-    ffiBracket = allocateEff_ ffiAlloc ffiDealloc
-      where
-        ffiAlloc = liftIO initializeFFI
-        ffiDealloc = liftIO shutdownFFI
+        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, Log "cam" :> es, Log "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
diff --git a/hsm-cam/Hsm/Cam/FFI.hs b/hsm-cam/Hsm/Cam/FFI.hs
index 93d2f57..50acf10 100644
--- a/hsm-cam/Hsm/Cam/FFI.hs
+++ b/hsm-cam/Hsm/Cam/FFI.hs
@@ -1,36 +1,64 @@
 {-# LANGUAGE CApiFFI #-}
 
 module Hsm.Cam.FFI
-  ( makeLogger
+  ( frameWidth
+  , frameHeight
+  , makeLogger
   , registerLogger
-  , makeCallback
-  , registerCallback
-  , initializeFFI
-  , shutdownFFI
-  , requestCapture
-  )
-where
+  , makeRequestCallback
+  , registerRequestCallback
+  , 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 RequestCallback = IO ()
+
+foreign import capi safe "Cam.hpp value FRAME_WIDTH" frameWidth :: Int
+
+foreign import capi safe "Cam.hpp value FRAME_HEIGHT" frameHeight :: Int
 
 foreign import ccall safe "wrapper" makeLogger :: Logger -> IO (FunPtr Logger)
 
-foreign import capi safe "Cam.hpp register_logger"
-  registerLogger :: FunPtr Logger -> IO ()
+foreign import capi safe "Cam.hpp register_logger" registerLogger :: FunPtr Logger -> IO ()
+
+foreign import ccall safe "wrapper" makeRequestCallback :: RequestCallback -> IO (FunPtr RequestCallback)
+
+foreign import capi safe "Cam.hpp register_request_callback" registerRequestCallback :: FunPtr RequestCallback -> IO ()
+
+foreign import capi safe "Cam.hpp start_camera_manager" startCameraManager :: IO ()
+
+foreign import capi safe "Cam.hpp stop_camera_manager" stopCameraManager :: IO ()
+
+foreign import capi safe "Cam.hpp acquire_camera" acquireCamera :: IO ()
+
+foreign import capi safe "Cam.hpp release_camera" releaseCamera :: IO ()
+
+foreign import capi safe "Cam.hpp allocate_frame_buffer" allocateFrameBuffer :: IO ()
+
+foreign import capi safe "Cam.hpp free_frame_buffer" freeFrameBuffer :: IO ()
 
-foreign import ccall safe "wrapper"
-  makeCallback :: Callback -> IO (FunPtr Callback)
+foreign import capi safe "Cam.hpp start_camera" startCamera :: IO ()
 
-foreign import capi safe "Cam.hpp register_callback"
-  registerCallback :: FunPtr Callback -> IO ()
+foreign import capi safe "Cam.hpp stop_camera" stopCamera :: IO ()
 
-foreign import capi safe "Cam.hpp initialize_ffi" initializeFFI :: IO ()
+foreign import capi safe "Cam.hpp create_request" createRequest :: IO ()
 
-foreign import capi safe "Cam.hpp shutdown_ffi" shutdownFFI :: IO ()
+foreign import capi safe "Cam.hpp get_dma_buffer_fd" getDmaBufferFd :: IO Fd
 
-foreign import capi safe "Cam.hpp request_capture" requestCapture :: IO ()
+foreign import capi safe "Cam.hpp request_frame" requestFrame :: IO ()
diff --git a/hsm-cam/Test/Cam.hs b/hsm-cam/Test/Cam.hs
index 4cf9e7f..5c8daf5 100644
--- a/hsm-cam/Test/Cam.hs
+++ b/hsm-cam/Test/Cam.hs
@@ -1,8 +1,12 @@
-import Data.Function ((&))
+import Control.Monad (forM_)
 import Effectful (runEff)
-import Effectful.Resource (runResource)
-import Hsm.Cam (runCam, stillCapture)
-import Hsm.Log (Severity (Trace), runLog)
+import Effectful.FileSystem (runFileSystem)
+import Effectful.FileSystem.IO.ByteString.Lazy (writeFile)
+import Hsm.Cam (capturePng, runCam)
+import Hsm.Log (Severity(Info, Trace), runLog)
+import Prelude hiding (writeFile)
 
 main :: IO ()
-main = stillCapture & runCam & runLog @"cam" Trace & runResource & runEff
+main =
+  runEff . runFileSystem . runLog @"cam" Trace . runLog @"libcamera" Info . runCam . forM_ [0 .. 31] $ \index ->
+    capturePng >>= writeFile ("/tmp/hsm-cam-test" <> show @Int index <> ".png")
diff --git a/hsm-cam/hsm-cam.cabal b/hsm-cam/hsm-cam.cabal
index a4aa467..7dd0dab 100644
--- a/hsm-cam/hsm-cam.cabal
+++ b/hsm-cam/hsm-cam.cabal
@@ -9,14 +9,21 @@ extra-source-files:
 library
   build-depends:
     , base
+    , bytestring
+    , directory
     , effectful-core
     , effectful-plugin
+    , extra
+    , hsm-core
     , hsm-log
-    , resourcet-effectful
-
-  cxx-options:
-    -O3 -Wall -Wextra -Werror -std=c++20 -I/usr/include/libcamera
+    , JuicyPixels
+    , monad-loops
+    , primitive
+    , shared-memory
+    , unix
+    , vector
 
+  cxx-options:      -O3 -Wall -Wextra -Werror -std=c++20
   cxx-sources:      FFI/Cam.cpp
   default-language: GHC2024
   exposed-modules:  Hsm.Cam
@@ -29,20 +36,28 @@ library
     -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
     -fplugin=Effectful.Plugin
 
-  include-dirs:     FFI Hsm/Cam
+  include-dirs:     FFI Hsm/Cam /usr/include/libcamera
   other-modules:    Hsm.Cam.FFI
 
 executable test-cam
   build-depends:
     , base
+    , bytestring
+    , directory
+    , effectful
     , effectful-core
     , effectful-plugin
+    , extra
+    , hsm-core
     , hsm-log
-    , resourcet-effectful
-
-  cxx-options:
-    -O3 -Wall -Wextra -Werror -std=c++20 -I/usr/include/libcamera
+    , JuicyPixels
+    , monad-loops
+    , primitive
+    , shared-memory
+    , unix
+    , vector
 
+  cxx-options:      -O3 -Wall -Wextra -Werror -std=c++20
   cxx-sources:      FFI/Cam.cpp
   default-language: GHC2024
   extra-libraries:
@@ -57,7 +72,7 @@ executable test-cam
   if !arch(x86_64)
     ghc-options: -optl=-mno-fix-cortex-a53-835769
 
-  include-dirs:     FFI Hsm/Cam
+  include-dirs:     FFI Hsm/Cam /usr/include/libcamera
   main-is:          Test/Cam.hs
   other-modules:
     Hsm.Cam
diff --git a/hsm-core/Hsm/Core/Bracket.hs b/hsm-core/Hsm/Core/Bracket.hs
new file mode 100644
index 0000000..f666d86
--- /dev/null
+++ b/hsm-core/Hsm/Core/Bracket.hs
@@ -0,0 +1,23 @@
+-- Resource management combinators for safe acquisition/release patterns.
+-- Provides specialized bracket variants for common scenarios.
+module Hsm.Core.Bracket
+  ( bracketConst
+  , bracketCont
+  , bracketLiftIO_
+  ) where
+
+import Control.Monad.Trans.Cont (Cont, cont)
+import Effectful (Eff, IOE, (:>), liftIO)
+import Effectful.Exception (bracket, bracket_)
+
+-- Ignores allocated resource in the action
+bracketConst :: Eff es a -> (a -> Eff es b) -> Eff es c -> Eff es c
+bracketConst alloc dealloc = bracket alloc dealloc . const
+
+-- Continuation-passing style integration
+bracketCont :: Eff es a -> (a -> Eff es b) -> Cont (Eff es c) a
+bracketCont alloc dealloc = cont $ bracket alloc dealloc
+
+-- Lifts IO operations into Effectful brackets
+bracketLiftIO_ :: IOE :> es => IO a -> IO b -> Eff es c -> Eff es c
+bracketLiftIO_ alloc dealloc = bracket_ (liftIO alloc) $ liftIO dealloc
diff --git a/hsm-core/Hsm/Core/Options.hs b/hsm-core/Hsm/Core/Options.hs
new file mode 100644
index 0000000..eeeee97
--- /dev/null
+++ b/hsm-core/Hsm/Core/Options.hs
@@ -0,0 +1,8 @@
+module Hsm.Core.Options
+  ( getOptions
+  ) where
+
+import Options.Applicative (Parser, (<**>), execParser, fullDesc, helper, info, progDesc)
+
+getOptions :: Parser a -> String -> IO a
+getOptions parser desc = execParser . info (parser <**> helper) $ fullDesc <> progDesc desc
diff --git a/hsm-core/Hsm/Core/Serial.hs b/hsm-core/Hsm/Core/Serial.hs
index a0efca3..9a4d2b7 100644
--- a/hsm-core/Hsm/Core/Serial.hs
+++ b/hsm-core/Hsm/Core/Serial.hs
@@ -36,13 +36,17 @@ import Language.Haskell.TH
 -- Generates a data type `GPIOPin` with constructors `GPIO2`, `GPIO3` `GPIO4`,
 -- and a function `pinLine :: GPIOPin -> Int`.
 makeSerial :: String -> String -> String -> Name -> [Int] -> Q [Dec]
-makeSerial name suffix mapFun mapType idxs =
-  return [DataD [] dtName [] Nothing (idxCons <$> idxs) [derivClause], SigD mapFunName . AppT (AppT ArrowT $ ConT dtName) $ ConT mapType, FunD mapFunName $ mapFunClause <$> idxs]
+makeSerial name suffix mapFunction mapType indices =
+  return
+    [ DataD [] dataName [] Nothing (indexCons <$> indices) [deriveClause]
+    , SigD mapFunctionName $ ArrowT `AppT` ConT dataName `AppT` ConT mapType
+    , FunD mapFunctionName $ mapFunctionClause <$> indices
+    ]
   where
-    dtName = mkName $ name <> suffix
-    idxName idx = mkName $ name <> show idx
-    idxCons idx = NormalC (idxName idx) []
-    derivClause = DerivClause Nothing [ConT ''Bounded, ConT ''Enum, ConT ''Show]
-    mapFunName = mkName mapFun
-    mapFunBody = NormalB . LitE . IntegerL . integerFromInt
-    mapFunClause idx = Clause [ConP (idxName idx) [] []] (mapFunBody idx) []
+    dataName = mkName $ name <> suffix
+    indexName index = mkName $ name <> show index
+    indexCons index = NormalC (indexName index) []
+    deriveClause = DerivClause Nothing [ConT ''Bounded, ConT ''Enum, ConT ''Show]
+    mapFunctionName = mkName mapFunction
+    mapFunctionBody = NormalB . LitE . IntegerL . integerFromInt
+    mapFunctionClause index = Clause [ConP (indexName index) [] []] (mapFunctionBody index) []
diff --git a/hsm-core/hsm-core.cabal b/hsm-core/hsm-core.cabal
index 856a359..e435f19 100644
--- a/hsm-core/hsm-core.cabal
+++ b/hsm-core/hsm-core.cabal
@@ -3,12 +3,18 @@ author:        Paul Oliver <contact@pauloliver.dev>
 name:          hsm-core
 version:       0.1.0.0
 
-
 library
   build-depends:
     , base
+    , effectful-core
+    , optparse-applicative
     , template-haskell
+    , transformers
 
   default-language: GHC2024
-  exposed-modules:  Hsm.Core.Serial
+  exposed-modules:
+    Hsm.Core.Bracket
+    Hsm.Core.Serial
+    Hsm.Core.Options
+
   ghc-options:      -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
index 4786379..fcb3a00 100644
--- a/hsm-gpio/Hsm/GPIO.hs
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -11,14 +11,15 @@ module Hsm.GPIO
   ) where
 
 import Control.Monad (forM_, void)
+import Control.Monad.Trans.Cont (evalCont)
 import Data.Vector.Storable (fromList, replicate, unsafeWith)
 import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
 import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
 import Effectful.Exception (bracket)
-import Effectful.Resource (Resource, allocateEff, releaseEff)
 import Foreign.C.String (withCString)
 import Foreign.C.Types (CSize(CSize), CUInt)
 import Foreign.Ptr (Ptr)
+import Hsm.Core.Bracket (bracketCont)
 import Hsm.Core.Serial (makeSerial)
 import Hsm.GPIO.FFI
   ( LineRequest
@@ -67,7 +68,7 @@ setPins :: (GPIO :> es, Log "gpio" :> es) => [GPIOPin] -> LineValue -> Eff es ()
 setPins pins lineValue = do
   GPIO lineRequest <- getStaticRep
   logMsg Trace $ "Setting pin(s) " <> show pins <> " to " <> show lineValue
-  forM_ pins $ \pin -> unsafeEff_ $ lineRequestSetValue lineRequest (pinLine pin) lineValue
+  unsafeEff_ . forM_ pins $ \pin -> lineRequestSetValue lineRequest (pinLine pin) lineValue
 
 setAllPins :: (GPIO :> es, Log "gpio" :> es) => LineValue -> Eff es ()
 setAllPins lineValue = do
@@ -75,68 +76,53 @@ setAllPins lineValue = do
   logMsg Trace $ "Setting all pins " <> show allPins <> " to " <> show lineValue
   unsafeEff_ . unsafeWith (replicate pinCount lineValue) $ void . lineRequestSetValues lineRequest
 
-runGPIO :: (IOE :> es, Log "gpio" :> es, Resource :> es) => String -> Eff (GPIO : es) a -> Eff es a
-runGPIO consumer action = do
-  (chipKey, chip) <- chipBracket
-  (lineSettingsKey, lineSettings) <- lineSettingsBracket
-  (lineConfigKey, lineConfig) <- lineConfigBracket lineSettings
-  (requestConfigKey, requestConfig) <- requestConfigBracket
-  lineRequestBracket chip requestConfig lineConfig $ \lineRequest -> do
-    releaseEff requestConfigKey
-    releaseEff lineConfigKey
-    releaseEff lineSettingsKey
-    releaseEff chipKey
-    evalStaticRep (GPIO lineRequest) action
+runGPIO :: (IOE :> es, Log "gpio" :> es) => String -> Eff (GPIO : es) a -> Eff es a
+runGPIO consumer action = bracket lineRequestAlloc lineRequestDealloc $ \lineRequest -> evalStaticRep (GPIO lineRequest) action
   where
-    chipBracket = allocateEff chipAlloc chipDealloc
-      where
-        chipPath = "/dev/gpiochip0"
-        chipAlloc = do
-          logMsg Info $ "Opening GPIO chip " <> chipPath
-          liftIO $ withCString chipPath chipOpen
-        chipDealloc chip = do
-          logMsg Info $ "Closing GPIO chip " <> chipPath
-          liftIO $ chipClose chip
-    lineSettingsBracket = allocateEff lineSettingsAlloc lineSettingsDealloc
-      where
-        lineSettingsAlloc = do
-          logMsg Info "Allocating line settings"
-          lineSettings <- liftIO lineSettingsNew
-          logMsg Info $ "With direction set to " <> show output
-          liftIO . void $ lineSettingsSetDirection lineSettings output
-          logMsg Info $ "With output set to " <> show inactive
-          liftIO . void $ lineSettingsSetOutputValue lineSettings inactive
-          return lineSettings
-        lineSettingsDealloc lineSettings = do
-          logMsg Info "Freeing line settings"
-          liftIO $ lineSettingsFree lineSettings
-    lineConfigBracket lineSettings = allocateEff lineConfigAlloc lineConfigDealloc
-      where
-        lineConfigAlloc = do
-          logMsg Info "Allocating line config"
-          logMsg Info $ "With GPIO pins " <> show allPins
-          lineConfig <- liftIO lineConfigNew
-          liftIO . void . unsafeWith (fromList allLines) $ \pinsVector -> lineConfigAddLineSettings lineConfig pinsVector (CSize $ fromIntegral pinCount) lineSettings
-          return lineConfig
-        lineConfigDealloc lineConfig = do
-          logMsg Info "Freeing line config"
-          liftIO $ lineConfigFree lineConfig
-    requestConfigBracket = allocateEff requestConfigAlloc requestConfigDealloc
-      where
-        requestConfigAlloc = do
-          logMsg Info "Allocating request config"
-          logMsg Info $ "With consumer " <> consumer
-          requestConfig <- liftIO requestConfigNew
-          liftIO . withCString consumer $ requestConfigSetConsumer requestConfig
-          return requestConfig
-        requestConfigDealloc requestConfig = do
-          logMsg Info "Freeing request config"
-          liftIO $ requestConfigFree requestConfig
-    lineRequestBracket chip requestConfig lineConfig = bracket lineRequestAlloc lineRequestDealloc
-      where
-        lineRequestAlloc = do
-          logMsg Info "Allocating line request"
-          liftIO $ chipRequestLines chip requestConfig lineConfig
-        lineRequestDealloc lineRequest = do
-          logMsg Info "Releasing line request"
-          liftIO $ lineRequestRelease lineRequest
+    chipPath = "/dev/gpiochip0"
+    chipAlloc = do
+      logMsg Info $ "Opening GPIO chip " <> chipPath
+      liftIO $ withCString chipPath chipOpen
+    chipDealloc chip = do
+      logMsg Info $ "Closing GPIO chip " <> chipPath
+      liftIO $ chipClose chip
+    lineSettingsAlloc = do
+      logMsg Info "Allocating line settings"
+      lineSettings <- liftIO lineSettingsNew
+      logMsg Info $ "With direction set to " <> show output
+      liftIO . void $ lineSettingsSetDirection lineSettings output
+      logMsg Info $ "With output set to " <> show inactive
+      liftIO . void $ lineSettingsSetOutputValue lineSettings inactive
+      return lineSettings
+    lineSettingsDealloc lineSettings = do
+      logMsg Info "Freeing line settings"
+      liftIO $ lineSettingsFree lineSettings
+    lineConfigAlloc lineSettings = do
+      logMsg Info "Allocating line config"
+      logMsg Info $ "With GPIO pins " <> show allPins
+      lineConfig <- liftIO lineConfigNew
+      liftIO . void . unsafeWith (fromList allLines) $ \pinsVector -> lineConfigAddLineSettings lineConfig pinsVector (CSize $ fromIntegral pinCount) lineSettings
+      return lineConfig
+    lineConfigDealloc lineConfig = do
+      logMsg Info "Freeing line config"
+      liftIO $ lineConfigFree lineConfig
+    requestConfigAlloc = do
+      logMsg Info "Allocating request config"
+      logMsg Info $ "With consumer " <> consumer
+      requestConfig <- liftIO requestConfigNew
+      liftIO . withCString consumer $ requestConfigSetConsumer requestConfig
+      return requestConfig
+    requestConfigDealloc requestConfig = do
+      logMsg Info "Freeing request config"
+      liftIO $ requestConfigFree requestConfig
+    lineRequestAlloc = do
+      logMsg Info "Allocating line request"
+      evalCont $ do
+        chip <- bracketCont chipAlloc chipDealloc
+        lineSettings <- bracketCont lineSettingsAlloc lineSettingsDealloc
+        lineConfig <- bracketCont (lineConfigAlloc lineSettings) lineConfigDealloc
+        requestConfig <- bracketCont requestConfigAlloc requestConfigDealloc
+        return . liftIO $ chipRequestLines chip requestConfig lineConfig
+    lineRequestDealloc lineRequest = do
+      logMsg Info "Releasing line request"
+      liftIO $ lineRequestRelease lineRequest
diff --git a/hsm-gpio/Hsm/GPIO/FFI.hs b/hsm-gpio/Hsm/GPIO/FFI.hs
index e0d6d07..2589e5e 100644
--- a/hsm-gpio/Hsm/GPIO/FFI.hs
+++ b/hsm-gpio/Hsm/GPIO/FFI.hs
@@ -38,9 +38,9 @@ import Foreign.Storable (Storable)
 
 data Chip
 
-foreign import ccall unsafe "gpiod.h gpiod_chip_open" chipOpen :: CString -> IO (Ptr Chip)
+foreign import capi safe "gpiod.h gpiod_chip_open" chipOpen :: CString -> IO (Ptr Chip)
 
-foreign import ccall unsafe "gpiod.h gpiod_chip_close" chipClose :: Ptr Chip -> IO ()
+foreign import capi safe "gpiod.h gpiod_chip_close" chipClose :: Ptr Chip -> IO ()
 
 data LineSettings
 
@@ -48,48 +48,48 @@ newtype LineDirection =
   LineDirection CInt
   deriving (Show)
 
-foreign import capi unsafe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT" input :: LineDirection
+foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT" input :: LineDirection
 
-foreign import capi unsafe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT" output :: LineDirection
+foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT" output :: LineDirection
 
 newtype LineValue =
   LineValue CInt
   deriving (Show, Storable)
 
-foreign import capi unsafe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE" active :: LineValue
+foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE" active :: LineValue
 
-foreign import capi unsafe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE" inactive :: LineValue
+foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE" inactive :: LineValue
 
-foreign import ccall unsafe "gpiod.h gpiod_line_settings_new" lineSettingsNew :: IO (Ptr LineSettings)
+foreign import capi safe "gpiod.h gpiod_line_settings_new" lineSettingsNew :: IO (Ptr LineSettings)
 
-foreign import ccall unsafe "gpiod.h gpiod_line_settings_free" lineSettingsFree :: Ptr LineSettings -> IO ()
+foreign import capi safe "gpiod.h gpiod_line_settings_free" lineSettingsFree :: Ptr LineSettings -> IO ()
 
-foreign import ccall unsafe "gpiod.h gpiod_line_settings_set_direction" lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
+foreign import capi safe "gpiod.h gpiod_line_settings_set_direction" lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
 
-foreign import ccall unsafe "gpiod.h gpiod_line_settings_set_output_value" lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
+foreign import capi safe "gpiod.h gpiod_line_settings_set_output_value" lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
 
 data LineConfig
 
-foreign import ccall unsafe "gpiod.h gpiod_line_config_new" lineConfigNew :: IO (Ptr LineConfig)
+foreign import capi safe "gpiod.h gpiod_line_config_new" lineConfigNew :: IO (Ptr LineConfig)
 
-foreign import ccall unsafe "gpiod.h gpiod_line_config_free" lineConfigFree :: Ptr LineConfig -> IO ()
+foreign import capi safe "gpiod.h gpiod_line_config_free" lineConfigFree :: Ptr LineConfig -> IO ()
 
-foreign import ccall unsafe "gpiod.h gpiod_line_config_add_line_settings" lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
+foreign import capi safe "gpiod.h gpiod_line_config_add_line_settings" lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
 
 data RequestConfig
 
-foreign import ccall unsafe "gpiod.h gpiod_request_config_new" requestConfigNew :: IO (Ptr RequestConfig)
+foreign import capi safe "gpiod.h gpiod_request_config_new" requestConfigNew :: IO (Ptr RequestConfig)
 
-foreign import ccall unsafe "gpiod.h gpiod_request_config_free" requestConfigFree :: Ptr RequestConfig -> IO ()
+foreign import capi safe "gpiod.h gpiod_request_config_free" requestConfigFree :: Ptr RequestConfig -> IO ()
 
-foreign import ccall unsafe "gpiod.h gpiod_request_config_set_consumer" requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
+foreign import capi safe "gpiod.h gpiod_request_config_set_consumer" requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
 
 data LineRequest
 
-foreign import ccall unsafe "gpiod.h gpiod_chip_request_lines" chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
+foreign import capi safe "gpiod.h gpiod_chip_request_lines" chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
 
-foreign import ccall unsafe "gpiod.h gpiod_line_request_release" lineRequestRelease :: Ptr LineRequest -> IO ()
+foreign import capi safe "gpiod.h gpiod_line_request_release" lineRequestRelease :: Ptr LineRequest -> IO ()
 
-foreign import ccall unsafe "gpiod.h gpiod_line_request_set_value" lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
+foreign import capi safe "gpiod.h gpiod_line_request_set_value" lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
 
-foreign import ccall unsafe "gpiod.h gpiod_line_request_set_values" lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
+foreign import capi safe "gpiod.h gpiod_line_request_set_values" lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
diff --git a/hsm-gpio/hsm-gpio.cabal b/hsm-gpio/hsm-gpio.cabal
index a56a67a..ba538db 100644
--- a/hsm-gpio/hsm-gpio.cabal
+++ b/hsm-gpio/hsm-gpio.cabal
@@ -10,7 +10,7 @@ library
     , effectful-plugin
     , hsm-core
     , hsm-log
-    , resourcet-effectful
+    , transformers
     , vector
 
   default-language: GHC2024
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index 3c25501..a0cf49c 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -5,27 +5,39 @@
 module Hsm.Log
   ( Severity(Attention, Info, Trace)
   , Log
-  , getLoggerIO
+  , getLevel
   , logMsg
+  , makeLoggerIO
+  , LoggerOptionPrefix
   , runLog
+  , runLogOpt
+  , runLogs
+  , runLogsOpt
   ) where
 
 import Control.Monad (when)
 import Data.Function (applyWhen)
+import Data.List (intercalate)
 import Data.Proxy (Proxy(Proxy))
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.ISO8601 (formatISO8601Millis)
 import Effectful (Dispatch(Static), DispatchOf, Eff, Effect, IOE, (:>))
-import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
-import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
-import GHC.TypeLits.Printf (printf)
-import String.ANSI (red)
+import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff, unsafeEff_)
+import GHC.Conc.Sync (fromThreadId, myThreadId)
+import GHC.Records (HasField, getField)
+import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal)
+import String.ANSI (blue, green, red, white)
 
 data Severity
   = Attention
   | Info
   | Trace
-  deriving (Enum, Eq, Ord, Show)
+  deriving (Enum, Eq, Ord, Read, Show)
+
+coloredShow :: Severity -> String
+coloredShow Attention = red "ATTENTION"
+coloredShow Info = green "INFO"
+coloredShow Trace = blue "TRACE"
 
 data Log (d :: Symbol) (a :: * -> *) (b :: *)
 
@@ -34,22 +46,27 @@ type instance DispatchOf (Log d) = Static WithSideEffects
 newtype instance StaticRep (Log d) =
   Log Severity
 
-getLoggerIO ::
-     forall d es. (KnownSymbol d, Log d :> es)
-  => Eff es (Severity -> String -> IO ())
-getLoggerIO = do
-  Log level <- getStaticRep
-  return $ \severity message ->
-    when (severity <= level) $ do
-      time <- formatISO8601Millis <$> getCurrentTime
-      putStrLn . applyWhen (severity == Attention) red $ printf "%s %s [%s] %s" time (symbolVal $ Proxy @d) (show severity) message
+getLevel :: Log d :> es => Eff es Severity
+getLevel = getStaticRep >>= \(Log level) -> return level
 
 logMsg ::
      forall d es. (KnownSymbol d, Log d :> es)
   => Severity
   -> String
   -> Eff es ()
-logMsg severity message = getLoggerIO >>= \loggerIO -> unsafeEff_ $ loggerIO severity message
+logMsg severity message = do
+  level <- getLevel
+  when (severity <= level) . unsafeEff_ $ do
+    time <- formatISO8601Millis <$> getCurrentTime
+    domainAndThreadId <- myThreadId >>= \tid -> return . white $ symbolVal (Proxy @d) <> ":" <> show (fromThreadId tid)
+    putStrLn $ unwords [time, domainAndThreadId, coloredShow severity, applyWhen (severity == Attention) red . intercalate "\n ... " $ lines message]
+
+makeLoggerIO ::
+     forall d es. (KnownSymbol d, Log d :> es)
+  => Eff es (Severity -> String -> IO ())
+makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env
+
+type LoggerOptionPrefix = "logLevel_"
 
 runLog ::
      forall d es a. IOE :> es
@@ -58,14 +75,24 @@ runLog ::
   -> Eff es a
 runLog = evalStaticRep . Log
 
-class Logs (ds :: [Symbol]) (es :: [Effect]) where
+runLogOpt ::
+     forall d f o es a. (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> es)
+  => o
+  -> Eff (Log d : es) a
+  -> Eff es a
+runLogOpt = runLog . getField @f
+
+class Logs (o :: *) (ds :: [Symbol]) (es :: [Effect]) where
   type Insert ds es :: [Effect]
   runLogs :: Severity -> Eff (Insert ds es) a -> Eff es a
+  runLogsOpt :: o -> Eff (Insert ds es) a -> Eff es a
 
-instance Logs ('[] :: [Symbol]) (es :: [Effect]) where
+instance Logs (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where
   type Insert '[] es = es
-  runLogs _ = id
+  runLogs = const id
+  runLogsOpt = const id
 
-instance (IOE :> Insert ds es, KnownSymbol d, Logs ds es) => Logs (d : ds :: [Symbol]) (es :: [Effect]) where
+instance (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, Logs o ds es) => Logs (o :: *) (d : ds :: [Symbol]) (es :: [Effect]) where
   type Insert (d : ds) es = Log d : Insert ds es
-  runLogs level = runLogs @ds level . runLog @d level
+  runLogs level = runLogs @o @ds level . runLog @d level
+  runLogsOpt opts = runLogsOpt @o @ds opts . runLogOpt @d @f @o opts
diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs
new file mode 100644
index 0000000..cb44f70
--- /dev/null
+++ b/hsm-log/Hsm/Log/Options.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module Hsm.Log.Options
+  ( makeLoggerOptionParser
+  ) where
+
+import Data.Proxy (Proxy(Proxy))
+import GHC.TypeLits (symbolVal)
+import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
+import Hsm.Log (LoggerOptionPrefix, Severity)
+import Language.Haskell.TH
+  ( Bang(Bang)
+  , Body(NormalB)
+  , Clause(Clause)
+  , Con(RecC)
+  , Dec(DataD, FunD, SigD)
+  , Exp(AppE, ConE, LitE, ParensE, UInfixE, VarE)
+  , Lit(StringL)
+  , Name
+  , Q
+  , SourceStrictness(NoSourceStrictness)
+  , SourceUnpackedness(NoSourceUnpackedness)
+  , Type(AppT, ConT)
+  , mkName
+  )
+import Options.Applicative (Parser, auto, help, long, metavar, option, showDefault, value)
+
+-- Generates an optparse-applicative parser for multiple logger severity levels
+--
+-- Creates a record type with configurable log levels and a corresponding parser
+-- that accepts command-line arguments like `--log-cam` and `--log-web`.
+--
+-- Example:
+--
+--   $(makeLoggerOptionParser @'[ "cam", "web"] "Options" "parser" 'Info)
+--
+-- Generates:
+-- * Record: `Options { logLevel_cam :: Severity, logLevel_web :: Severity }`
+-- * Parser: `parser :: Parser Options` with default values set to `Info`
+makeLoggerOptionParser ::
+     forall ls. KnownSymbols ls
+  => String
+  -> String
+  -> Name
+  -> Q [Dec]
+makeLoggerOptionParser dataNameString parserNameString defaultSeverity =
+  return
+    [ DataD [] dataName [] Nothing [RecC dataName $ field <$> loggers] []
+    , SigD parserName $ ConT ''Parser `AppT` ConT dataName
+    , FunD parserName [Clause [] (NormalB $ foldl parserApply parserBase loggers) []]
+    ]
+  where
+    loggers = symbolVals @ls
+    -- Record
+    dataName = mkName dataNameString
+    fieldPrefix = symbolVal $ Proxy @LoggerOptionPrefix
+    fieldName logger = mkName $ fieldPrefix <> logger
+    fieldBang = Bang NoSourceUnpackedness NoSourceStrictness
+    fieldType = ConT ''Severity
+    field logger = (fieldName logger, fieldBang, fieldType)
+    -- Parser
+    parserName = mkName parserNameString
+    parserBase = VarE 'pure `AppE` ConE dataName
+    parserConfigApply expr = UInfixE expr $ VarE '(<>)
+    parserOptionLong logger = VarE 'long `AppE` LitE (StringL $ "log-" <> logger)
+    parserOptionHelp logger = VarE 'help `AppE` LitE (StringL $ "Sets log level for logger " <> logger)
+    parserOptionShowDefault = VarE 'showDefault
+    parserOptionValue = VarE 'value `AppE` ConE defaultSeverity
+    parserOptionMetavar = VarE 'metavar `AppE` LitE (StringL "LEVEL")
+    parserOptions logger = [parserOptionLong logger, parserOptionHelp logger, parserOptionShowDefault, parserOptionValue, parserOptionMetavar]
+    parserApply expr logger = UInfixE expr (VarE '(<*>)) $ VarE 'option `AppE` VarE 'auto `AppE` ParensE (foldl1 parserConfigApply $ parserOptions logger)
diff --git a/hsm-log/hsm-log.cabal b/hsm-log/hsm-log.cabal
index 7aab0de..f20d201 100644
--- a/hsm-log/hsm-log.cabal
+++ b/hsm-log/hsm-log.cabal
@@ -8,13 +8,18 @@ library
     , base
     , effectful-core
     , effectful-plugin
+    , generic-data-functions
     , iso8601-time
+    , optparse-applicative
+    , template-haskell
     , text-ansi
     , time
-    , typelits-printf
 
   default-language: GHC2024
-  exposed-modules:  Hsm.Log
+  exposed-modules:
+    Hsm.Log
+    Hsm.Log.Options
+
   ghc-options:
     -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
     -fplugin=Effectful.Plugin
diff --git a/hsm-repl/Hsm/Repl.hs b/hsm-repl/Hsm/Repl.hs
index dacc76a..6bcf39d 100644
--- a/hsm-repl/Hsm/Repl.hs
+++ b/hsm-repl/Hsm/Repl.hs
@@ -15,6 +15,7 @@ import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
 import Hsm.Log (Log, Severity(Attention, Info, Trace), logMsg)
 import Language.Haskell.Interpreter (GhcError(errMsg), InterpreterError(WontCompile), as, interpret, runInterpreter, setImports)
+import String.ANSI (blue)
 import System.Console.Haskeline (defaultSettings, getInputLine, handleInterrupt, withInterrupt)
 import System.Console.Haskeline.IO (InputState, cancelInput, initializeInput, queryInput)
 
@@ -33,7 +34,7 @@ repl = query >>= maybe (return Nothing) parse
     query = do
       Repl inputState <- getStaticRep
       logMsg Trace $ "Expecting a value of type: " <> show (typeRep $ Proxy @t)
-      unsafeEff_ . queryInput inputState . handleInterrupt (return Nothing) . withInterrupt . getInputLine $ symbolVal (Proxy @p)
+      unsafeEff_ . queryInput inputState . handleInterrupt (return Nothing) . withInterrupt . getInputLine . blue $ symbolVal (Proxy @p)
     parse string = do
       logMsg Trace $ "Parsing string: " <> string
       eitherValue <-
diff --git a/hsm-repl/Test/Repl.hs b/hsm-repl/Test/Repl.hs
index 2d299b8..8588718 100644
--- a/hsm-repl/Test/Repl.hs
+++ b/hsm-repl/Test/Repl.hs
@@ -1,8 +1,7 @@
 import Control.Monad.Loops (whileJust_)
-import Data.Function ((&))
 import Effectful (runEff)
 import Hsm.Log (Severity(Trace), runLog)
 import Hsm.Repl (repl, runRepl)
 
 main :: IO ()
-main = whileJust_ repl return & runRepl @"exec-repl λ " @'[ "Prelude"] @[Bool] & runLog @"repl" Trace & runEff
+main = runEff . runLog @"repl" Trace . runRepl @"exec-repl λ " @'[ "Prelude"] @[Bool] $ whileJust_ repl return
diff --git a/hsm-repl/hsm-repl.cabal b/hsm-repl/hsm-repl.cabal
index eb755a6..5d9a794 100644
--- a/hsm-repl/hsm-repl.cabal
+++ b/hsm-repl/hsm-repl.cabal
@@ -12,6 +12,7 @@ library
     , haskeline
     , hint
     , hsm-log
+    , text-ansi
 
   default-language: GHC2024
   exposed-modules:  Hsm.Repl
@@ -29,6 +30,7 @@ executable test-repl
     , hint
     , hsm-log
     , monad-loops
+    , text-ansi
 
   default-language: GHC2024
   ghc-options:
diff --git a/hsm-web/Hsm/Web.hs b/hsm-web/Hsm/Web.hs
new file mode 100644
index 0000000..975f556
--- /dev/null
+++ b/hsm-web/Hsm/Web.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.Web
+  ( Web
+  , runServer
+  , runWeb
+  ) where
+
+import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
+import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff)
+import Effectful.Dispatch.Static.Primitive (Env)
+import Effectful.Exception (finally)
+import Hsm.Cam (Cam, capturePng)
+import Hsm.Log (Log, Severity(Info, Trace), logMsg, makeLoggerIO)
+import Network.Wai.Handler.Warp (defaultSettings, setLogger)
+import Paths_hsm_web (getDataFileName)
+import Web.Scotty (Options(settings, verbose), defaultOptions, file, get, liftIO, raw, scottyOpts, setHeader)
+
+data Web (a :: * -> *) (b :: *)
+
+type instance DispatchOf Web = Static WithSideEffects
+
+newtype instance StaticRep Web =
+  Web Options
+
+server :: (Cam :> es, Log "cam" :> es) => Options -> Env es -> IO ()
+server options env = do
+  index <- getDataFileName "Html/index.html"
+  scottyOpts options $ do
+    get "/" $ file index
+    get "/cam.png" $ do
+      setHeader "Content-Type" "image/png"
+      liftIO (unEff capturePng env) >>= raw
+
+runServer :: (Cam :> es, Log "cam" :> es, Log "web" :> es, Web :> es) => Eff es ()
+runServer = finally startServer stopServer
+  where
+    startServer = do
+      Web options <- getStaticRep
+      logMsg @"web" Info "Starting scotty web server"
+      unsafeEff $ server options
+    stopServer = logMsg @"web" Info "Stopping scotty web server"
+
+runWeb :: (IOE :> es, Log "scotty" :> es, Log "web" :> es) => Eff (Web : es) a -> Eff es a
+runWeb action = do
+  logMsg @"web" Info "Registering logger for scotty web server"
+  scottyLogger <- makeLoggerIO @"scotty" >>= return . logRequest
+  evalStaticRep (Web $ defaultOptions {verbose = 0, settings = setLogger scottyLogger defaultSettings}) action
+  where
+    logRequest loggerIO request status fileSize = loggerIO Trace $ unwords [show request, show status, show fileSize]
diff --git a/hsm-web/Html/index.html b/hsm-web/Html/index.html
new file mode 100644
index 0000000..030e8e5
--- /dev/null
+++ b/hsm-web/Html/index.html
@@ -0,0 +1,34 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <title>HsMouse Monitor</title>
+    <meta charset="utf-8"/>
+  </head>
+  <body>
+    <h2>HsMouse Monitor</h2>
+    <img id="my_img"></img>
+  </body>
+  <script>
+    function updateImg() {
+      fetch("cam.png")
+        .then(response => response.blob())
+        .then(function(myBlob){
+          URL.revokeObjectURL(my_img.src)
+          my_img.src = URL.createObjectURL(myBlob)
+          updateImg()
+        })
+    }
+    updateImg()
+  </script>
+  <style>
+    body, html {
+      background-color: #002b36;
+      color: #586e75;
+      font-family: monospace;
+    }
+    img {
+      outline: 2px solid #586e75;
+      width: 100%;
+    }
+  </style>
+</html>
diff --git a/hsm-web/Main.hs b/hsm-web/Main.hs
new file mode 100644
index 0000000..2661370
--- /dev/null
+++ b/hsm-web/Main.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import Effectful (runEff)
+import Hsm.Cam (runCam)
+import Hsm.Core.Options (getOptions)
+import Hsm.Log (Severity(Info), runLogsOpt)
+import Hsm.Log.Options (makeLoggerOptionParser)
+import Hsm.Web (runServer, runWeb)
+
+-- Import full module for cleaner `-ddump-splices` output
+-- Avoids package/module qualifiers in generated code
+import Options.Applicative
+
+type Loggers = '[ "cam", "libcamera", "scotty", "web"]
+
+$(makeLoggerOptionParser @Loggers "Options" "parser" 'Info)
+
+main :: IO ()
+main = getOptions parser "Launch HsMouse Web Server" >>= \opts -> runEff . runLogsOpt @Options @Loggers opts . runCam . runWeb $ runServer
diff --git a/hsm-web/hsm-web.cabal b/hsm-web/hsm-web.cabal
new file mode 100644
index 0000000..ca631b4
--- /dev/null
+++ b/hsm-web/hsm-web.cabal
@@ -0,0 +1,48 @@
+cabal-version: 3.8
+author:        Paul Oliver <contact@pauloliver.dev>
+name:          hsm-web
+version:       0.1.0.0
+data-files:    Html/index.html
+
+library
+  build-depends:
+    , base
+    , effectful-core
+    , effectful-plugin
+    , hsm-cam
+    , hsm-log
+    , scotty
+    , warp
+
+  default-language: GHC2024
+  exposed-modules:  Hsm.Web
+  ghc-options:
+    -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
+    -fplugin=Effectful.Plugin
+
+  other-modules:    Paths_hsm_web
+
+executable hsm-web
+  build-depends:
+    , base
+    , effectful-core
+    , effectful-plugin
+    , hsm-cam
+    , hsm-core
+    , hsm-log
+    , optparse-applicative
+    , scotty
+    , warp
+
+  default-language: GHC2024
+  ghc-options:
+    -O2 -threaded -Wall -Werror -Wno-star-is-type -Wunused-packages -Wno-unused-imports
+    -ddump-splices -fplugin=Effectful.Plugin
+
+  if !arch(x86_64)
+    ghc-options: -optl=-mno-fix-cortex-a53-835769
+
+  main-is:          Main.hs
+  other-modules:
+    Hsm.Web
+    Paths_hsm_web
diff --git a/stack.yaml b/stack.yaml
index 8834008..a226236 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -8,4 +8,5 @@ packages:
   - hsm-log
   - hsm-pwm
   - hsm-repl
-resolver: lts-24.6
+  - hsm-web
+resolver: lts-24.8
diff --git a/stack.yaml.lock b/stack.yaml.lock
index b27e1f1..550b233 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -20,7 +20,7 @@ packages:
     hackage: typelits-printf-0.3.0.0
 snapshots:
 - completed:
-    sha256: 473840099b95facf73ec72dcafe53a2487bfadeceb03a981a19e16469503a342
-    size: 726266
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/6.yaml
-  original: lts-24.6
+    sha256: d347039f81388e16ea93ddaf9ff1850abfba8f8680ff75fbdd177692542ceb26
+    size: 726286
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/8.yaml
+  original: lts-24.8