Adds libcamera bindings

10 files changed, 353 insertions, 7 deletions

diff --git a/README.md b/README.md
index d74a71e..dbfbc28 100644
--- a/README.md
+++ b/README.md
@@ -52,6 +52,25 @@ follow these steps:
 This configuration ensures that GPIO and PWM operations can be performed
 without needing root access.
 
+## Libcamera Setup
+The upstream libcamera package in Arch Linux ARM (as of August 2025) has
+compatibility issues with the Raspberry Pi kernel, preventing detection of
+official camera modules. Until this is resolved upstream, you'll need to build
+the Raspberry Pi Foundation's supported version:
+```console
+user@alarm$ sudo pacman -S boost cmake gcc git libdrm libexif libjpeg libpng libtiff meson pkgconf python-jinja python-ply python-yaml
+user@alarm$ git clone https://github.com/raspberrypi/libcamera
+user@alarm$ cd libcamera
+user@alarm$ meson setup build -Dprefix=/usr
+user@alarm$ ninja -C build
+user@alarm$ sudo ninja -C build install
+```
+
+References:
+
+- [RPi Kernel Issue #6983](https://github.com/raspberrypi/linux/issues/6983)
+- [Libcamera Installation Guide](https://blog.jirkabalhar.cz/2024/02/raspberry-camera-on-archlinux-arm-in-2024/)
+
 ## Build Instructions:
 1. Install [`stack`](https://docs.haskellstack.org/en/stable/). It’s
    recommended to use [`ghcup`](https://www.haskell.org/ghcup/) for
diff --git a/hsm-cam/FFI/Cam.cpp b/hsm-cam/FFI/Cam.cpp
new file mode 100644
index 0000000..5f2ca1f
--- /dev/null
+++ b/hsm-cam/FFI/Cam.cpp
@@ -0,0 +1,85 @@
+#include <format>
+
+#include <libcamera/libcamera.h>
+
+#include "Cam.hpp"
+
+using namespace libcamera;
+using namespace std;
+
+HsLogger g_logger;
+HsCallback g_callback;
+unique_ptr<CameraManager> g_manager;
+shared_ptr<Camera> g_camera;
+unique_ptr<CameraConfiguration> g_config;
+unique_ptr<FrameBufferAllocator> g_allocator;
+unique_ptr<Request> g_request;
+
+template <class... Args>
+void logMsg(Severity severity, const format_string<Args...> fmt, const Args&... args) {
+    g_logger(severity, vformat(fmt.get(), make_format_args(args...)).c_str());
+}
+
+void request_complete(Request *request) {
+    logMsg(Trace, "Completed request");
+    g_callback(request->buffers().begin()->second->planes()[0].fd.get());
+}
+
+extern "C" void register_logger(HsLogger hs_logger) {
+    g_logger = hs_logger;
+    logMsg(Info, "Registered FFI logger");
+}
+
+extern "C" void register_callback(HsCallback hs_callback) {
+    g_callback = hs_callback;
+    logMsg(Info, "Registered FFI callback");
+}
+
+extern "C" void initialize_ffi() {
+    logMsg(Info, "Starting camera manager");
+    g_manager = make_unique<CameraManager>();
+    g_manager->start();
+
+    logMsg(Info, "Acquiring camera");
+    g_camera = g_manager->cameras()[0];
+    g_camera->acquire();
+
+    logMsg(Info, "Generating still capture configuration");
+    g_config = g_camera->generateConfiguration({StreamRole::StillCapture});
+    g_camera->configure(g_config.get());
+
+    logMsg(Info, "Allocating buffer");
+    g_allocator = make_unique<FrameBufferAllocator>(g_camera);
+    g_allocator->allocate((*g_config)[0].stream());
+
+    logMsg(Info, "Registering request complete callback");
+    g_camera->requestCompleted.connect(request_complete);
+
+    logMsg(Info, "Starting camera");
+    g_camera->start();
+}
+
+extern "C" void shutdown_ffi() {
+    logMsg(Info, "Stopping camera");
+    g_camera->stop();
+
+    logMsg(Info, "Freeing frame buffer allocator");
+    g_allocator->free((*g_config)[0].stream());
+    g_allocator.reset();
+
+    logMsg(Info, "Releasing camera");
+    g_camera->release();
+    g_camera.reset();
+
+    logMsg(Info, "Stopping camera manager");
+    g_manager->stop();
+}
+
+extern "C" void request_capture() {
+    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());
+    g_camera->queueRequest(g_request.get());
+}
diff --git a/hsm-cam/FFI/Cam.hpp b/hsm-cam/FFI/Cam.hpp
new file mode 100644
index 0000000..e59fa1d
--- /dev/null
+++ b/hsm-cam/FFI/Cam.hpp
@@ -0,0 +1,25 @@
+#ifndef CAM_HPP
+#define CAM_HPP
+
+enum Severity {
+    Attention = 0,
+    Info = 1,
+    Trace = 2,
+};
+
+typedef void (*HsLogger)(enum Severity, const char *);
+typedef void (*HsCallback)(int fd);
+
+#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();
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs
new file mode 100644
index 0000000..9857557
--- /dev/null
+++ b/hsm-cam/Hsm/Cam.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.Cam
+  ( Cam
+  , stillCapture
+  , runCam
+  )
+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 Foreign.C.String (peekCString)
+import Foreign.Ptr (freeHaskellFunPtr)
+import Hsm.Cam.FFI
+  ( initializeFFI
+  , makeCallback
+  , makeLogger
+  , registerCallback
+  , registerLogger
+  , requestCapture
+  , shutdownFFI
+  )
+import Hsm.Log (Log, Severity (Info, Trace), getLoggerIO, logMsg)
+
+data Cam (a :: * -> *) (b :: *)
+
+type instance DispatchOf Cam = Static WithSideEffects
+
+newtype instance StaticRep Cam
+  = Cam (MVar Int)
+
+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
+
+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
+  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
+      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
diff --git a/hsm-cam/Hsm/Cam/FFI.hsc b/hsm-cam/Hsm/Cam/FFI.hsc
new file mode 100644
index 0000000..44f3f4b
--- /dev/null
+++ b/hsm-cam/Hsm/Cam/FFI.hsc
@@ -0,0 +1,40 @@
+{-# LANGUAGE CApiFFI #-}
+
+module Hsm.Cam.FFI
+  ( makeLogger
+  , registerLogger
+  , makeCallback
+  , registerCallback
+  , initializeFFI
+  , shutdownFFI
+  , requestCapture
+  )
+where
+
+import Foreign.C.String (CString)
+import Foreign.Ptr (FunPtr)
+
+type Logger = Int -> CString -> IO ()
+
+type Callback = Int -> IO ()
+
+foreign import ccall safe "wrapper"
+  makeLogger :: Logger -> IO (FunPtr Logger)
+
+foreign import capi safe "Cam.hpp register_logger"
+  registerLogger :: FunPtr Logger -> IO ()
+
+foreign import ccall safe "wrapper"
+  makeCallback :: Callback -> IO (FunPtr Callback)
+
+foreign import capi safe "Cam.hpp register_callback"
+  registerCallback :: FunPtr Callback -> IO ()
+
+foreign import capi safe "Cam.hpp initialize_ffi"
+  initializeFFI :: IO ()
+
+foreign import capi safe "Cam.hpp shutdown_ffi"
+  shutdownFFI :: IO ()
+
+foreign import capi safe "Cam.hpp request_capture"
+  requestCapture :: IO ()
diff --git a/hsm-cam/Test/Cam.hs b/hsm-cam/Test/Cam.hs
new file mode 100644
index 0000000..4cf9e7f
--- /dev/null
+++ b/hsm-cam/Test/Cam.hs
@@ -0,0 +1,8 @@
+import Data.Function ((&))
+import Effectful (runEff)
+import Effectful.Resource (runResource)
+import Hsm.Cam (runCam, stillCapture)
+import Hsm.Log (Severity (Trace), runLog)
+
+main :: IO ()
+main = stillCapture & runCam & runLog @"cam" Trace & runResource & runEff
diff --git a/hsm-cam/hsm-cam.cabal b/hsm-cam/hsm-cam.cabal
new file mode 100644
index 0000000..a4aa467
--- /dev/null
+++ b/hsm-cam/hsm-cam.cabal
@@ -0,0 +1,64 @@
+cabal-version:      3.8
+author:             Paul Oliver <contact@pauloliver.dev>
+name:               hsm-cam
+version:            0.1.0.0
+extra-source-files:
+  FFI/Cam.cpp
+  FFI/Cam.hpp
+
+library
+  build-depends:
+    , base
+    , effectful-core
+    , effectful-plugin
+    , hsm-log
+    , resourcet-effectful
+
+  cxx-options:
+    -O3 -Wall -Wextra -Werror -std=c++20 -I/usr/include/libcamera
+
+  cxx-sources:      FFI/Cam.cpp
+  default-language: GHC2024
+  exposed-modules:  Hsm.Cam
+  extra-libraries:
+    camera
+    camera-base
+    stdc++
+
+  ghc-options:
+    -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
+    -fplugin=Effectful.Plugin
+
+  include-dirs:     FFI Hsm/Cam
+  other-modules:    Hsm.Cam.FFI
+
+executable test-cam
+  build-depends:
+    , base
+    , effectful-core
+    , effectful-plugin
+    , hsm-log
+    , resourcet-effectful
+
+  cxx-options:
+    -O3 -Wall -Wextra -Werror -std=c++20 -I/usr/include/libcamera
+
+  cxx-sources:      FFI/Cam.cpp
+  default-language: GHC2024
+  extra-libraries:
+    camera
+    camera-base
+    stdc++
+
+  ghc-options:
+    -O2 -threaded -Wall -Werror -Wno-star-is-type -Wunused-packages
+    -fplugin=Effectful.Plugin
+
+  if !arch(x86_64)
+    ghc-options: -optl=-mno-fix-cortex-a53-835769
+
+  include-dirs:     FFI Hsm/Cam
+  main-is:          Test/Cam.hs
+  other-modules:
+    Hsm.Cam
+    Hsm.Cam.FFI
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index 5321910..088be8e 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -5,6 +5,7 @@
 module Hsm.Log
   ( Severity (Attention, Info, Trace)
   , Log
+  , getLoggerIO
   , logMsg
   , runLog
   )
@@ -31,7 +32,7 @@ data Severity
   = Attention
   | Info
   | Trace
-  deriving (Eq, Ord, Show)
+  deriving (Enum, Eq, Ord, Show)
 
 data Log (d :: Symbol) (a :: * -> *) (b :: *)
 
@@ -40,18 +41,31 @@ 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
+
 logMsg
   :: forall d es
    . (KnownSymbol d, Log d :> es)
   => Severity
   -> String
   -> Eff es ()
-logMsg severity message = do
-  Log level <- getStaticRep
-  unsafeEff_ . when (severity <= level) $ do
-    time <- formatISO8601Millis <$> getCurrentTime
-    putStrLn . applyWhen (severity == Attention) red $
-      printf "%s %s [%s] %s" time (symbolVal $ Proxy @d) (show level) message
+logMsg severity message =
+  getLoggerIO >>= \loggerIO -> unsafeEff_ $ loggerIO severity message
 
 runLog
   :: forall d es a
diff --git a/stack.yaml b/stack.yaml
index 01991a1..ffefbb1 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -2,6 +2,7 @@ extra-deps:
   - resourcet-effectful-1.0.1.0
   - typelits-printf-0.3.0.0
 packages:
+  - hsm-cam
   - hsm-core
   - hsm-gpio
   - hsm-log
diff --git a/sysconf/97-libcamera.rules b/sysconf/97-libcamera.rules
new file mode 100644
index 0000000..7b7a4fa
--- /dev/null
+++ b/sysconf/97-libcamera.rules
@@ -0,0 +1,3 @@
+SUBSYSTEM=="dma_heap",KERNEL=="linux*",GROUP="video",MODE="0660"
+SUBSYSTEM=="dma_heap",KERNEL=="reserved",GROUP="video",MODE="0660"
+SUBSYSTEM=="dma_heap",KERNEL=="system",GROUP="video",MODE="0660"