diff options
60 files changed, 1736 insertions, 1360 deletions
@@ -1,2 +1 @@ **/.stack-work/ -.hsm_command_history diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..68fc7ca --- /dev/null +++ b/Makefile @@ -0,0 +1,11 @@ +resolver = $(shell curl -s https://www.stackage.org/download/snapshots.json | yq .lts) +packages = $(shell ls -dQm hsm-*) + +build: + stack build + +clean: + stack clean --full + +update: + yq -i '.resolver="$(resolver)" | .packages=[$(packages)]' stack.yaml @@ -1,52 +1,81 @@ # HsMouse -Experimental control code for robotics. Tested on Raspberry Pi 5. - -## Features -- [`zeromq4-haskell`](https://hackage.haskell.org/package/zeromq4-haskell) -library is used for IPC. -- [`effectful`](https://hackage.haskell.org/package/effectful) library is used -to control effects within monadic computations. -- [`streamly`](https://hackage.haskell.org/package/streamly) library is used -to build pipelines modularly and stream data within pipeline elements. E.g. -`zmq client & processor & zmq server`. - -## Build -Install [`stack`](https://docs.haskellstack.org/en/stable/). I recommend using -[`ghcup`](https://www.haskell.org/ghcup/) for this. Run `stack build` to -compile all libraries and executables. Note: you might need to install some -system dependencies on your host first (e.g. `libzmq`, etc.) - -## Test -On one terminal, run `stack exec dummy-receiver`. This will initialize a ZMQ -client that will wait for incoming pulses. On a separate terminal, run -`stack exec dummy-pulser`. You should be able to see pulses being transmitted -from server to client. E.g.: +Experimental control software for robotics, tested on Raspberry Pi 5. + +## System Configuration: +To configure the system, the files in the `sysconf` directory must be +installed: + +1. Copy the UDEV `*.rule` files into `/etc/udev/rules.d` +2. Copy `config.txt` to `/boot` +3. Reboot the Raspberry Pi for the changes to take effect + +## Low Power Consumption When Powered Off: +By default, the Raspberry Pi 5 keeps the SoC powered on (in a shutdown state) +even after the system is shut down. As a result, it continues to consume +1.2-1.6W of power, even with nothing plugged in except for power. For more +details, see: +[Reducing Raspberry Pi 5's Power Consumption](https://www.jeffgeerling.com/blog/2023/reducing-raspberry-pi-5s-power-consumption-140x) + +This can be easily fixed by editing the EEPROM configuration with the +following command: +```console +user@alarm$ sudo rpi-eeprom-config -e ``` -$> stack exec dummy-receiver -2025-01-12 21:27:02 INFO receiver/client: Initializing ZMQ client -2025-01-12 21:27:16 INFO receiver/receiver: Received pulse #1 -2025-01-12 21:27:17 INFO receiver/receiver: Received pulse #2 -2025-01-12 21:27:18 INFO receiver/receiver: Received pulse #3 -2025-01-12 21:27:19 INFO receiver/receiver: Received pulse #4 -2025-01-12 21:27:20 INFO receiver/receiver: Received pulse #5 -2025-01-12 21:27:21 INFO receiver/receiver: Received pulse #6 -2025-01-12 21:27:22 INFO receiver/receiver: Received pulse #7 -2025-01-12 21:27:23 INFO receiver/receiver: Received pulse #8 -2025-01-12 21:27:24 INFO receiver/receiver: Received pulse #9 +Ensure that `POWER_OFF_ON_HALT=1` is set, while leaving the other variables +unchanged: +```config +[all] +BOOT_UART=[...] +POWER_OFF_ON_HALT=1 +BOOT_ORDER=[...] ``` +To run `rpi-eeprom-config` on Arch Linux, you’ll need to install the +`rpi5-eeprom` package from the `PKGBUILDs` repository. Run the following +commands to do so: +```console +user@alarm$ git clone https://github.com/archlinuxarm/PKGBUILDs +user@alarm$ cd PKGBUILDs/alarm/rpi-eeprom +user@alarm$ makepkg -s +user@alarm$ sudo pacman -U rpi5-eeprom-*.pkg.tar.xz ``` -$> stack exec dummy-pulser -2025-01-12 21:27:15 INFO pulser/server: Initializing ZMQ server -2025-01-12 21:27:16 INFO pulser/fsm/run: Sending pulse #1 -2025-01-12 21:27:17 INFO pulser/fsm/run: Sending pulse #2 -2025-01-12 21:27:18 INFO pulser/fsm/run: Sending pulse #3 -2025-01-12 21:27:19 INFO pulser/fsm/run: Sending pulse #4 -2025-01-12 21:27:20 INFO pulser/fsm/run: Sending pulse #5 -2025-01-12 21:27:21 INFO pulser/fsm/run: Sending pulse #6 -2025-01-12 21:27:22 INFO pulser/fsm/run: Sending pulse #7 -2025-01-12 21:27:23 INFO pulser/fsm/run: Sending pulse #8 -2025-01-12 21:27:24 INFO pulser/fsm/run: Sending pulse #9 -2025-01-12 21:27:25 ATTENTION pulser/fsm/run: Reached 10 pulses -2025-01-12 21:27:25 ATTENTION pulser/fsm: No state returned, exiting FSM + +## GPIO and PWM Access Without Root: +To enable GPIO and PWM access without root privileges on the Raspberry Pi 5, +follow these steps: + +1. Create two new user groups: `gpiod` and `pwm` +2. Add your user to both groups +3. The UDEV rules installed previously will grant the `gpiod` and `pwm` user + groups permission to access the respective subsystems. + +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 + installation. +2. Run `make` to compile the libraries and executables + +> Note: You may need to install system dependencies on your host first (e.g., +> `libgpiod`, `libcamera`, etc.) diff --git a/hsm-cam/FFI/Cam.cpp b/hsm-cam/FFI/Cam.cpp new file mode 100644 index 0000000..4c21e7f --- /dev/null +++ b/hsm-cam/FFI/Cam.cpp @@ -0,0 +1,145 @@ +#include "Cam.hpp" + +#include <libcamera/libcamera.h> + +#include <format> + +using namespace libcamera; +using namespace std; + +HsLogger g_logger; +HsRequestCallback g_request_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 +internal_request_callback(Request *request) +{ + int sequence = request->buffers().begin()->second->metadata().sequence; + logMsg(Trace, "Completed request #{}", sequence); + g_request_callback(); +} + +extern "C" void +register_logger(HsLogger hs_logger) +{ + g_logger = hs_logger; + logMsg(Info, "Registered FFI logger"); +} + +extern "C" void +register_request_callback(HsRequestCallback hs_request_callback) +{ + g_request_callback = hs_request_callback; + logMsg(Info, "Registered FFI request callback"); +} + +extern "C" void +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()); +} + +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, "Generating frame buffer allocator"); + g_allocator = make_unique<FrameBufferAllocator>(g_camera); + g_allocator->allocate(g_config->at(0).stream()); + + 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 +stop_camera() +{ + logMsg(Info, "Stopping camera"); + g_camera->stop(); +} + +extern "C" void +create_request() +{ + logMsg(Info, "Creating request"); + g_request = g_camera->createRequest(); + + logMsg(Info, "Setting buffer for request"); + Stream *stream = g_config->at(0).stream(); + g_request->addBuffer(stream, g_allocator->buffers(stream)[0].get()); +} + +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_frame() +{ + 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 new file mode 100644 index 0000000..eeea814 --- /dev/null +++ b/hsm-cam/FFI/Cam.hpp @@ -0,0 +1,39 @@ +#ifndef CAM_HPP +#define CAM_HPP + +#define FRAME_WIDTH (800) +#define FRAME_HEIGHT (600) + +enum Severity +{ + Attention = 0, + Info = 1, + Trace = 2, +}; + +typedef void (*HsLogger)(enum Severity, const char *); +typedef void (*HsRequestCallback)(); + +#ifdef __cplusplus +extern "C" +{ +#endif + void register_logger(HsLogger hs_logger); + 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 + +#endif diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs new file mode 100644 index 0000000..d1f9cd2 --- /dev/null +++ b/hsm-cam/Hsm/Cam.hs @@ -0,0 +1,194 @@ +{-# 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, 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, 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.hsc b/hsm-cam/Hsm/Cam/FFI.hsc new file mode 100644 index 0000000..6c5dd3d --- /dev/null +++ b/hsm-cam/Hsm/Cam/FFI.hsc @@ -0,0 +1,82 @@ +{-# LANGUAGE CApiFFI #-} + +module Hsm.Cam.FFI + ( frameWidth + , frameHeight + , makeLogger + , registerLogger + , 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 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 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 capi safe "Cam.hpp start_camera" + startCamera :: IO () + +foreign import capi safe "Cam.hpp stop_camera" + stopCamera :: IO () + +foreign import capi safe "Cam.hpp create_request" + createRequest :: IO () + +foreign import capi safe "Cam.hpp get_dma_buffer_fd" + getDmaBufferFd :: IO Fd + +foreign import capi safe "Cam.hpp request_frame" + requestFrame :: IO () diff --git a/hsm-cam/Test/Cam.hs b/hsm-cam/Test/Cam.hs new file mode 100644 index 0000000..94d3b73 --- /dev/null +++ b/hsm-cam/Test/Cam.hs @@ -0,0 +1,17 @@ +import Control.Monad (forM_) +import Data.Function ((&)) +import Effectful (runEff) +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 = + forM_ [0 .. 31] (\index -> capturePng >>= writeFile ("/tmp/hsm-cam-test" <> show @Int index <> ".png")) + & runCam + & runLog @"cam" Trace + & runLog @"libcamera" Info + & runFileSystem + & runEff diff --git a/hsm-cam/hsm-cam.cabal b/hsm-cam/hsm-cam.cabal new file mode 100644 index 0000000..7dd0dab --- /dev/null +++ b/hsm-cam/hsm-cam.cabal @@ -0,0 +1,79 @@ +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 + , bytestring + , directory + , effectful-core + , effectful-plugin + , extra + , hsm-core + , hsm-log + , 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 + 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 /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 + , 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: + 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 /usr/include/libcamera + main-is: Test/Cam.hs + other-modules: + Hsm.Cam + Hsm.Cam.FFI diff --git a/hsm-command/Hsm/Command/Command.hs b/hsm-command/Hsm/Command/Command.hs deleted file mode 100644 index 53964c4..0000000 --- a/hsm-command/Hsm/Command/Command.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - -module Hsm.Command.Command - ( Direction(X, Z) - , Angle(CW, CCW) - , Speed(Slow, Mid, Fast) - , Command(Move, Rotate) - , commandStream - ) where - -import Data.Binary (Binary) -import Data.Maybe (fromJust, isJust) -import Data.Text (pack) -import Effectful (Eff, (:>)) -import Effectful.Log (Log, logAttention_) -import GHC.Generics (Generic) -import Hsm.Command.Readline (Readline, readline) -import Streamly.Data.Stream qualified as S -import Text.Read (readEither) - -data Direction - = X - | Z - deriving (Binary, Generic, Read, Show) - -data Angle - = CW - | CCW - deriving (Binary, Generic, Read, Show) - -data Speed - = Slow - | Mid - | Fast - deriving (Binary, Generic, Read, Show) - -data Command - = Move Direction Speed Int - | Rotate Angle Speed Int - deriving (Binary, Generic, Read, Show) - -commandStream :: (Log :> es, Readline :> es) => S.Stream (Eff es) Command -commandStream = - S.mapMaybeM (parse . fromJust) $ S.takeWhile isJust $ S.repeatM readline - where - parse string = - case readEither string of - Left err -> logAttention_ (pack err) >> return Nothing - Right command -> return $ Just command diff --git a/hsm-command/Hsm/Command/Readline.hs b/hsm-command/Hsm/Command/Readline.hs deleted file mode 100644 index 1caa562..0000000 --- a/hsm-command/Hsm/Command/Readline.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} - -module Hsm.Command.Readline - ( Readline - , readline - , runReadline - ) where - -import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>)) -import Effectful.Dispatch.Static qualified as S -import Effectful.Log (Log) -import Effectful.Resource (Resource, allocate) -import Hsm.Core.Log (flushLogger) -import System.Console.Haskeline qualified as H -import System.Console.Haskeline.IO qualified as H - -data Readline a b - -type instance DispatchOf Readline = Static S.WithSideEffects - -newtype instance S.StaticRep Readline = - Readline H.InputState - -readline :: (Log :> es, Readline :> es) => Eff es (Maybe String) -readline = do - flushLogger - Readline hdl <- S.getStaticRep - S.unsafeEff_ - $ H.queryInput hdl - $ H.handleInterrupt (return Nothing) - $ H.withInterrupt - $ H.getInputLine "% " - -runReadline :: (IOE :> es, Resource :> es) => Eff (Readline : es) a -> Eff es a -runReadline action = do - handle <- snd <$> allocate (H.initializeInput settings) H.cancelInput - S.evalStaticRep (Readline handle) action - where - settings = H.defaultSettings {H.historyFile = Just ".hsm_command_history"} diff --git a/hsm-command/Main.hs b/hsm-command/Main.hs deleted file mode 100644 index efcbc6e..0000000 --- a/hsm-command/Main.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -import Data.Function ((&)) -import Data.Text (Text) -import Effectful (runEff) -import Effectful.Log (runLog) -import Effectful.Reader.Static (runReader) -import Effectful.Resource (runResource) -import Hsm.Command.Command (commandStream) -import Hsm.Command.Readline (runReadline) -import Hsm.Core.App (launch) -import Hsm.Core.Env (deriveFromYaml) -import Hsm.Core.Zmq.Server (runServer, send) - -data Env = Env - { name :: Text - , pubEp :: Text - } - -$(deriveFromYaml ''Env) - --- Command Service: --- Reads movement commands from the terminal and publishes them through ZMQ. -main :: IO () -main = - launch @Env "command" id $ \env logger level -> - (commandStream & send @Env) - & runServer @Env - & runLog env.name logger level - & runReader env - & runReadline - & runResource - & runEff diff --git a/hsm-command/hsm-command.cabal b/hsm-command/hsm-command.cabal deleted file mode 100644 index 836bf07..0000000 --- a/hsm-command/hsm-command.cabal +++ /dev/null @@ -1,49 +0,0 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev -name: hsm-command -version: 0.1.0.0 - -library - build-depends: - , base - , binary - , effectful-core - , haskeline - , hsm-core - , log-effectful - , resourcet-effectful - , streamly-core - , text - - exposed-modules: - Hsm.Command.Command - Hsm.Command.Readline - - ghc-options: -Wall -Wunused-packages - default-language: GHC2021 - -executable command - build-depends: - , base - , binary - , effectful-core - , haskeline - , hsm-core - , log-effectful - , resourcet-effectful - , streamly-core - , text - - main-is: Main.hs - other-modules: - Hsm.Command.Command - Hsm.Command.Readline - - ghc-options: -Wall -Wunused-packages - - if !arch(x86_64) - ghc-options: -optl=-mno-fix-cortex-a53-835769 - - default-language: GHC2021 diff --git a/hsm-core/Hsm/Core/App.hs b/hsm-core/Hsm/Core/App.hs index 11759be..88dabb2 100644 --- a/hsm-core/Hsm/Core/App.hs +++ b/hsm-core/Hsm/Core/App.hs @@ -1,21 +1,20 @@ +-- Provides combinators for bootstrapping applications with: +-- - Automated command-line parsing +-- - Help text generation module Hsm.Core.App - ( launch - ) where + ( bootstrapApp + , bootstrapAppNoEcho + ) +where -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Effectful.Log (LogLevel, Logger) -import Hsm.Core.Env (environment) -import Hsm.Core.Options (Options(Options), options) -import Log.Backend.StandardOutput (withStdOutLogger) +import Data.Composition ((.:.)) +import Options.Applicative (Parser, execParser, fullDesc, helper, info, progDesc, (<**>)) +import System.IO.Echo (withoutInputEcho) -launch :: - FromJSON env - => Text - -> (IO app -> IO app) - -> (env -> Logger -> LogLevel -> IO app) - -> IO app -launch name wrapper app = do - Options path level <- options name - env <- environment name path - wrapper $ withStdOutLogger $ \logger -> app env logger level +-- Launches a console application with input echo enabled +bootstrapApp :: Parser o -> String -> (o -> IO a) -> IO a +bootstrapApp parser desc app = execParser (info (parser <**> helper) $ fullDesc <> progDesc desc) >>= app + +-- Launches an application with hidden input echo +bootstrapAppNoEcho :: Parser o -> String -> (o -> IO a) -> IO a +bootstrapAppNoEcho = withoutInputEcho .:. bootstrapApp diff --git a/hsm-core/Hsm/Core/Bracket.hs b/hsm-core/Hsm/Core/Bracket.hs new file mode 100644 index 0000000..92428de --- /dev/null +++ b/hsm-core/Hsm/Core/Bracket.hs @@ -0,0 +1,24 @@ +-- 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/Env.hs b/hsm-core/Hsm/Core/Env.hs deleted file mode 100644 index 8ef7464..0000000 --- a/hsm-core/Hsm/Core/Env.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Hsm.Core.Env - ( environment - , deriveFromYaml - ) where - -import Data.Aeson (FromJSON, Result(Error, Success), fromJSON) -import Data.Aeson.Key (fromText) -import Data.Aeson.KeyMap ((!?)) -import Data.Aeson.TH (defaultOptions, deriveFromJSON, rejectUnknownFields) -import Data.Maybe (fromMaybe) -import Data.Text (Text, unpack) -import Data.Yaml (decodeFileThrow) -import Language.Haskell.TH (Dec, Name, Q) - -environment :: FromJSON env => Text -> Text -> IO env -environment name = fmap (check . fromJSON . load) . decodeFileThrow . unpack - where - load keymap = - fromMaybe - (error $ "Service configuration for " <> unpack name <> " not found)") - $ keymap !? fromText name - check (Success env) = env - check (Error str) = error str - -deriveFromYaml :: Name -> Q [Dec] -deriveFromYaml = deriveFromJSON defaultOptions {rejectUnknownFields = True} diff --git a/hsm-core/Hsm/Core/Fsm.hs b/hsm-core/Hsm/Core/Fsm.hs deleted file mode 100644 index d1c2f5d..0000000 --- a/hsm-core/Hsm/Core/Fsm.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE OverloadedStrings #-} - -module Hsm.Core.Fsm - ( FsmState(FsmState) - , FsmOutput(FsmOutput) - , FsmResult(FsmResult) - , fsm - ) where - -import Data.Maybe (fromJust, isJust) -import Data.Text (Text) -import Effectful (Eff, (:>)) -import Effectful.Log (Log, LogLevel, localDomain, logAttention_, logTrace_) -import Effectful.Reader.Static (Reader, ask) -import Effectful.State.Static.Local (State, get, put) -import Hsm.Core.Log (logTup) -import Streamly.Data.Stream qualified as S (Stream, mapM, takeWhile) - -data FsmState i o env sta = - FsmState Text (i -> env -> sta -> FsmOutput i o env sta) - -data FsmOutput i o env sta = - FsmOutput (Maybe (FsmResult i o env sta)) [(LogLevel, Text)] - -data FsmResult i o env sta = - FsmResult o sta (FsmState i o env sta) - --- Finite state machines allow processing of stream elements using pure --- functions. One or more FSMs can be included within a `Streamly` pipeline. -fsm :: - forall i o env sta es. - ( Log :> es - , Reader env :> es - , State (FsmState i o env sta) :> es - , State sta :> es - ) - => S.Stream (Eff es) i - -> S.Stream (Eff es) o -fsm = S.mapM (return . fromJust) . S.takeWhile isJust . S.mapM run - where - exit = do - logAttention_ "No state returned, exiting FSM" - return Nothing - push (FsmResult out sta next) = do - put sta - put next - return $ Just out - run input = - localDomain "fsm" $ do - FsmState name action <- get - sta <- get @sta - env <- ask @env - logTrace_ $ "Entering state " <> name - FsmOutput res logs <- return $ action input env sta - localDomain name $ mapM_ logTup logs - logTrace_ $ "Exiting state " <> name - maybe exit push res diff --git a/hsm-core/Hsm/Core/Log.hs b/hsm-core/Hsm/Core/Log.hs deleted file mode 100644 index 6930e90..0000000 --- a/hsm-core/Hsm/Core/Log.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Hsm.Core.Log - ( withLogIO - , logTup - , flushLogger - ) where - -import Data.Aeson.Types (emptyObject) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime) -import Effectful (Eff, (:>)) -import Effectful.Dispatch.Static (unsafeEff_) -import Effectful.Log qualified as L - --- Helper function allows logging within IO, Useful during `resourcet` --- allocation and release operations. -withLogIO :: L.Log :> es => Eff es (L.LogLevel -> Text -> IO ()) -withLogIO = do - logIO <- L.getLoggerIO - return $ \level message -> do - now <- getCurrentTime - logIO now level message emptyObject - -logTup :: L.Log :> es => (L.LogLevel, Text) -> Eff es () -logTup (level, message) = L.logMessage level message emptyObject - -flushLogger :: L.Log :> es => Eff es () -flushLogger = L.getLoggerEnv >>= unsafeEff_ . L.waitForLogger . L.leLogger diff --git a/hsm-core/Hsm/Core/Message.hs b/hsm-core/Hsm/Core/Message.hs deleted file mode 100644 index b2a9f23..0000000 --- a/hsm-core/Hsm/Core/Message.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Hsm.Core.Message - ( message - , topic - , body - ) where - -import Data.Binary (Binary, decode, encode) -import Data.ByteString (ByteString, fromStrict, toStrict) -import Data.ByteString.Char8 qualified as B (breakSubstring, drop, length) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) - -sep :: ByteString -sep = "//" - -message :: Binary a => Text -> a -> ByteString -message t b = encodeUtf8 t <> sep <> toStrict (encode b) - -topic :: ByteString -> Text -topic = decodeUtf8 . fst . B.breakSubstring sep - -body :: Binary a => ByteString -> a -body = decode . fromStrict . B.drop (B.length sep) . snd . B.breakSubstring sep diff --git a/hsm-core/Hsm/Core/Options.hs b/hsm-core/Hsm/Core/Options.hs deleted file mode 100644 index 29e40a4..0000000 --- a/hsm-core/Hsm/Core/Options.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Hsm.Core.Options - ( Options(Options) - , options - ) where - -import Control.Applicative ((<**>)) -import Data.Text (Text, pack, unpack) -import Effectful.Log (LogLevel(LogInfo), readLogLevelEither, showLogLevel) -import Options.Applicative qualified as P -import Options.Applicative.Text qualified as P - -data Options = - Options Text LogLevel - -parser :: P.Parser Options -parser = - Options - <$> P.textOption - (P.help "Path to services config file" - <> P.short 'c' - <> P.long "config" - <> P.metavar "PATH" - <> P.value "servconf.yaml" - <> P.showDefault) - <*> P.option - (P.eitherReader $ readLogLevelEither . pack) - (P.help "Log level" - <> P.short 'l' - <> P.long "log-level" - <> P.metavar "LEVEL" - <> P.value LogInfo - <> P.showDefaultWith (unpack . showLogLevel)) - -options :: Text -> IO Options -options name = - P.customExecParser (P.prefs $ P.columns 100) - $ P.info (parser <**> P.helper) - $ P.fullDesc <> P.progDesc ("Launch " <> unpack name <> " service") diff --git a/hsm-core/Hsm/Core/Serial.hs b/hsm-core/Hsm/Core/Serial.hs new file mode 100644 index 0000000..7c607ff --- /dev/null +++ b/hsm-core/Hsm/Core/Serial.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Hsm.Core.Serial + ( makeSerial + ) +where + +import GHC.Num (integerFromInt) +import Language.Haskell.TH + ( Body (NormalB) + , Clause (Clause) + , Con (NormalC) + , Dec (DataD, FunD, SigD) + , DerivClause (DerivClause) + , Exp (LitE) + , Lit (IntegerL) + , Name + , Pat (ConP) + , Q + , Type (AppT, ArrowT, ConT) + , mkName + ) + +-- Generates a serial data type with the given name and a set of constructors, +-- each mapped to a corresponding integer value. +-- +-- - The data type derives `Bounded`, `Enum`, and `Show` for convenience. +-- - A companion mapping function is also generated, converting each constructor +-- to its associated integer. +-- +-- For debugging purposes, use `-ddump-splices` to inspect the generated code. +-- +-- Example: +-- +-- $(makeSerial "GPIO" "Pin" "pinLine" ''Int [2, 3, 4]) +-- +-- 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 mapFunction mapType indices = + return + [ DataD [] dataName [] Nothing (indexCons <$> indices) [deriveClause] + , SigD mapFunctionName $ ArrowT `AppT` ConT dataName `AppT` ConT mapType + , FunD mapFunctionName $ mapFunctionClause <$> indices + ] + where + 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/Zmq.hs b/hsm-core/Hsm/Core/Zmq.hs deleted file mode 100644 index 2f70d48..0000000 --- a/hsm-core/Hsm/Core/Zmq.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Hsm.Core.Zmq - ( withSocket - ) where - -import Effectful (Eff, IOE, (:>)) -import Effectful.Log (Log, LogLevel(LogTrace)) -import Effectful.Resource (Resource, allocate) -import Hsm.Core.Log (withLogIO) -import System.ZMQ4 qualified as Z - -withSocket :: - (Z.SocketType t, IOE :> es, Log :> es, Resource :> es) - => t - -> Eff es (Z.Socket t) -withSocket stype = withLogIO >>= bracket - where - bracket logIO = snd . snd <$> allocate acquire release - where - acquire = - logIO LogTrace "Acquiring ZMQ context" >> do - cont <- Z.context - sock <- Z.socket cont stype - return (cont, sock) - release (cont, sock) = - logIO LogTrace "Releasing ZMQ context" >> do - Z.close sock - Z.shutdown cont diff --git a/hsm-core/Hsm/Core/Zmq/Client.hs b/hsm-core/Hsm/Core/Zmq/Client.hs deleted file mode 100644 index 6093e54..0000000 --- a/hsm-core/Hsm/Core/Zmq/Client.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module Hsm.Core.Zmq.Client - ( Client - , receive - , poll - , runClient - ) where - -import Control.Monad (forM_) -import Control.Monad.Loops (whileM) -import Data.Binary (Binary) -import Data.Text (Text, pack, unpack) -import Data.Text.Encoding (encodeUtf8) -import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>)) -import Effectful.Dispatch.Static qualified as E -import Effectful.Log (Log, localDomain, logInfo_, logTrace_) -import Effectful.Reader.Static (Reader, ask) -import Effectful.Resource (Resource) -import GHC.Records (HasField) -import Hsm.Core.Message (body, topic) -import Hsm.Core.Zmq (withSocket) -import Streamly.Data.Stream (Stream, repeatM) -import System.ZMQ4 qualified as Z - -data Client a b - -type instance DispatchOf Client = Static E.WithSideEffects - -newtype instance E.StaticRep Client = - Client (Z.Socket Z.Sub) - -domain :: Text -domain = "client" - -receiver :: - forall es a. (Log :> es, Client :> es, Binary a, Show a) - => Eff es a -receiver = do - Client sock <- E.getStaticRep - message <- E.unsafeEff_ $ Z.receive sock - localDomain domain - $ logTrace_ - $ "Message received [" - <> topic message - <> "]: " - <> pack (show $ body @a message) - return $ body message - -receive :: (Log :> es, Client :> es, Binary a, Show a) => Stream (Eff es) a -receive = repeatM receiver - -poll :: (Log :> es, Client :> es, Binary a, Show a) => Stream (Eff es) [a] -poll = - repeatM $ do - ms <- whileM newMsg receiver - localDomain domain - $ localDomain "poller" - $ logTrace_ - $ pack (show $ length ms) <> " new message(s) on queue" - return ms - where - newMsg = do - Client sock <- E.getStaticRep - peek <- E.unsafeEff_ $ Z.poll 0 [Z.Sock sock [Z.In] Nothing] - return $ peek /= [[]] - -runClient :: - forall env es a. - ( HasField "subEps" env [Text] - , HasField "topics" env [Text] - , IOE :> es - , Log :> es - , Reader env :> es - , Resource :> es - ) - => Eff (Client : es) a - -> Eff es a -runClient action = - withSocket Z.Sub >>= \sock -> - E.evalStaticRep (Client sock) $ do - localDomain domain $ do - logInfo_ "Initializing ZMQ client" - env <- ask @env - forM_ env.subEps $ E.unsafeEff_ . Z.connect sock . unpack - forM_ env.topics $ E.unsafeEff_ . Z.subscribe sock . encodeUtf8 - logTrace_ $ "Listening to " <> pack (show env.subEps) - logTrace_ $ "Subscribed to " <> pack (show env.topics) - action diff --git a/hsm-core/Hsm/Core/Zmq/Server.hs b/hsm-core/Hsm/Core/Zmq/Server.hs deleted file mode 100644 index 2e9217b..0000000 --- a/hsm-core/Hsm/Core/Zmq/Server.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module Hsm.Core.Zmq.Server - ( Server - , send - , runServer - ) where - -import Data.Binary (Binary) -import Data.Text (Text, pack, unpack) -import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>)) -import Effectful.Dispatch.Static qualified as E -import Effectful.Log (Log, localDomain, logInfo_, logTrace_) -import Effectful.Reader.Static (Reader, ask) -import Effectful.Resource (Resource) -import GHC.Records (HasField) -import Hsm.Core.Message (message) -import Hsm.Core.Zmq (withSocket) -import Streamly.Data.Fold qualified as S (drain) -import Streamly.Data.Stream qualified as S (Stream, fold, mapM) -import System.ZMQ4 qualified as Z - -data Server a b - -type instance DispatchOf Server = Static E.WithSideEffects - -newtype instance E.StaticRep Server = - Server (Z.Socket Z.Pub) - -domain :: Text -domain = "server" - -send :: - forall env es a. - ( HasField "name" env Text - , Log :> es - , Reader env :> es - , Server :> es - , Binary a - , Show a - ) - => S.Stream (Eff es) a - -> Eff es () -send = S.fold S.drain . S.mapM sender - where - sender payload = do - Server sock <- E.getStaticRep - env <- ask @env - E.unsafeEff_ $ Z.send sock [] $ message env.name payload - localDomain domain $ logTrace_ $ "Message sent: " <> pack (show payload) - -runServer :: - forall env es a. - ( HasField "pubEp" env Text - , IOE :> es - , Log :> es - , Reader env :> es - , Resource :> es - ) - => Eff (Server : es) a - -> Eff es a -runServer action = - withSocket Z.Pub >>= \sock -> - E.evalStaticRep (Server sock) $ do - localDomain domain $ do - logInfo_ "Initializing ZMQ server" - env <- ask @env - E.unsafeEff_ $ Z.bind sock $ unpack env.pubEp - logTrace_ $ "Publishing to " <> env.pubEp - action diff --git a/hsm-core/hsm-core.cabal b/hsm-core/hsm-core.cabal index bbdbbb3..6a0efff 100644 --- a/hsm-core/hsm-core.cabal +++ b/hsm-core/hsm-core.cabal @@ -1,42 +1,22 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev +cabal-version: 3.8 +author: Paul Oliver <contact@pauloliver.dev> name: hsm-core version: 0.1.0.0 library build-depends: - , aeson , base - , binary - , bytestring + , composition + , echo , effectful-core - , log-base - , log-effectful - , monad-loops , optparse-applicative - , optparse-text - , resourcet-effectful - , streamly-core , template-haskell - , text - , time - , yaml - , zeromq4-haskell + , transformers + default-language: GHC2024 exposed-modules: Hsm.Core.App - Hsm.Core.Env - Hsm.Core.Fsm - Hsm.Core.Log - Hsm.Core.Message - Hsm.Core.Zmq.Client - Hsm.Core.Zmq.Server + Hsm.Core.Bracket + Hsm.Core.Serial - other-modules: - Hsm.Core.Options - Hsm.Core.Zmq - - ghc-options: -Wall -Wunused-packages - default-language: GHC2021 + ghc-options: -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages diff --git a/hsm-dummy-blinker/Main.hs b/hsm-dummy-blinker/Main.hs deleted file mode 100644 index 88b7b5f..0000000 --- a/hsm-dummy-blinker/Main.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -import Data.Function ((&)) -import Data.Set (fromList) -import Data.Text (Text) -import Effectful (Eff, (:>), runEff) -import Effectful.Log (Log, LogLevel(LogInfo), runLog) -import Effectful.Reader.Static (Reader, ask, runReader) -import Effectful.Resource (runResource) -import Effectful.State.Static.Local (evalState) -import Hsm.Core.App (launch) -import Hsm.Core.Env (deriveFromYaml) -import Hsm.Core.Fsm qualified as F -import Hsm.GPIO (GPIO, GPIOEffect, runGPIO, toggle) -import Streamly.Data.Fold qualified as S (drain) -import Streamly.Data.Stream qualified as S (Stream, fold, mapM, repeat) -import System.IO.Echo (withoutInputEcho) - -data Env = Env - { name :: Text - , gpio :: [GPIO] - , period :: Int - } - -$(deriveFromYaml ''Env) - -stateOn :: F.FsmState () Bool Env Bool -stateOn = - F.FsmState "on" $ \_ _ sta -> - F.FsmOutput - (Just $ F.FsmResult sta False stateOff) - [(LogInfo, "Turning on blinker")] - -stateOff :: F.FsmState () Bool Env Bool -stateOff = - F.FsmState "off" $ \_ _ sta -> - F.FsmOutput - (Just $ F.FsmResult sta True stateOn) - [(LogInfo, "Turning off blinker")] - -handle :: - (GPIOEffect () :> es, Log :> es, Reader Env :> es) - => S.Stream (Eff es) Bool - -> Eff es () -handle = S.fold S.drain . S.mapM handler - where - handler sta = do - env <- ask @Env - toggle sta () [env.period, 0] - --- Dummy blinker service: --- Proof of concept. This service toggles a GPIO on and off using a set --- period. -main :: IO () -main = - launch @Env "dummy-blinker" withoutInputEcho $ \env logger level -> - (S.repeat () & F.fsm @_ @_ @Env @Bool & handle) - & runGPIO (\() -> fromList env.gpio) - & evalState False - & evalState stateOff - & runLog env.name logger level - & runReader env - & runResource - & runEff diff --git a/hsm-dummy-blinker/hsm-dummy-blinker.cabal b/hsm-dummy-blinker/hsm-dummy-blinker.cabal deleted file mode 100644 index 670252e..0000000 --- a/hsm-dummy-blinker/hsm-dummy-blinker.cabal +++ /dev/null @@ -1,27 +0,0 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev -name: hsm-dummy-blinker -version: 0.1.0.0 - -executable dummy-blinker - build-depends: - , base - , containers - , echo - , effectful-core - , hsm-core - , hsm-gpio - , log-effectful - , resourcet-effectful - , streamly-core - , text - - main-is: Main.hs - ghc-options: -Wall -Wunused-packages - - if !arch(x86_64) - ghc-options: -optl=-mno-fix-cortex-a53-835769 - - default-language: GHC2021 diff --git a/hsm-dummy-fail/Main.hs b/hsm-dummy-fail/Main.hs deleted file mode 100644 index 4e293c8..0000000 --- a/hsm-dummy-fail/Main.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -import Data.Function ((&)) -import Data.Text (Text) -import Effectful (Eff, (:>), runEff) -import Effectful.Concurrent (Concurrent, runConcurrent, threadDelay) -import Effectful.Log (runLog) -import Effectful.Reader.Static (Reader, asks, runReader) -import Effectful.Resource (runResource) -import Hsm.Core.App (launch) -import Hsm.Core.Env (deriveFromYaml) -import Hsm.Core.Zmq.Server (runServer, send) -import Hsm.Status.Error (Error(Error)) -import Streamly.Data.Stream (Stream, fromEffect) -import System.IO.Echo (withoutInputEcho) - -data Env = Env - { name :: Text - , pubEp :: Text - , alive :: Int - } - -$(deriveFromYaml ''Env) - -singleError :: (Concurrent :> es, Reader Env :> es) => Stream (Eff es) Error -singleError = - fromEffect $ do - -- Seemingly, the service needs to be alive for a bit for ZMQ comms to - -- kick in. - asks alive >>= threadDelay - return $ Error 0 "Sent from dummy-fail service" - --- Dummy fail service: --- Proof of concept. Publishes a single error that can be catched by a --- listening client. -main :: IO () -main = - launch @Env "dummy-fail" withoutInputEcho $ \env logger level -> - (singleError & send @Env) - & runServer @Env - & runConcurrent - & runLog env.name logger level - & runReader env - & runResource - & runEff diff --git a/hsm-dummy-fail/hsm-dummy-fail.cabal b/hsm-dummy-fail/hsm-dummy-fail.cabal deleted file mode 100644 index 269ea9c..0000000 --- a/hsm-dummy-fail/hsm-dummy-fail.cabal +++ /dev/null @@ -1,26 +0,0 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev -name: hsm-dummy-fail -version: 0.1.0.0 - -executable dummy-fail - build-depends: - , base - , echo - , effectful - , hsm-core - , hsm-status - , log-effectful - , resourcet-effectful - , streamly-core - , text - - main-is: Main.hs - ghc-options: -Wall -Wunused-packages - - if !arch(x86_64) - ghc-options: -optl=-mno-fix-cortex-a53-835769 - - default-language: GHC2021 diff --git a/hsm-dummy-poller/Main.hs b/hsm-dummy-poller/Main.hs deleted file mode 100644 index 9f2fad9..0000000 --- a/hsm-dummy-poller/Main.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -import Control.Monad (forM_) -import Data.Function ((&)) -import Data.Text (Text, pack) -import Effectful (Eff, (:>), runEff) -import Effectful.Concurrent (Concurrent, runConcurrent, threadDelay) -import Effectful.Log (Log, localDomain, logInfo_, runLog) -import Effectful.Reader.Static (Reader, asks, runReader) -import Effectful.Resource (runResource) -import Hsm.Core.App (launch) -import Hsm.Core.Env (deriveFromYaml) -import Hsm.Core.Zmq.Client (poll, runClient) -import Streamly.Data.Fold qualified as S (drain) -import Streamly.Data.Stream qualified as S (Stream, fold, mapM) -import System.IO.Echo (withoutInputEcho) - -data Env = Env - { name :: Text - , subEps :: [Text] - , topics :: [Text] - , period :: Int - } - -$(deriveFromYaml ''Env) - -handle :: - (Concurrent :> es, Log :> es, Reader Env :> es) - => S.Stream (Eff es) [Int] - -> Eff es () -handle = - S.fold S.drain . S.mapM (\p -> asks period >>= threadDelay >> handler p) - where - receiverDomain = "receiver" - handler [] = localDomain receiverDomain $ logInfo_ "No pulse received yet" - handler ps = - forM_ ps $ \p -> - localDomain receiverDomain - $ logInfo_ - $ "Received pulse #" <> pack (show p) - --- Dummy poller service: --- Proof of concept. Polls for "pulses" through ZMQ at a set interval and --- logs each time one is received. -main :: IO () -main = - launch @Env "dummy-poller" withoutInputEcho $ \env logger level -> - (poll & handle) - & runClient @Env - & runConcurrent - & runLog env.name logger level - & runReader env - & runResource - & runEff diff --git a/hsm-dummy-poller/hsm-dummy-poller.cabal b/hsm-dummy-poller/hsm-dummy-poller.cabal deleted file mode 100644 index 801cf68..0000000 --- a/hsm-dummy-poller/hsm-dummy-poller.cabal +++ /dev/null @@ -1,25 +0,0 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev -name: hsm-dummy-poller -version: 0.1.0.0 - -executable dummy-poller - build-depends: - , base - , echo - , effectful - , hsm-core - , log-effectful - , resourcet-effectful - , streamly-core - , text - - main-is: Main.hs - ghc-options: -Wall -Wunused-packages - - if !arch(x86_64) - ghc-options: -optl=-mno-fix-cortex-a53-835769 - - default-language: GHC2021 diff --git a/hsm-dummy-pulser/Main.hs b/hsm-dummy-pulser/Main.hs deleted file mode 100644 index d15b616..0000000 --- a/hsm-dummy-pulser/Main.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -import Data.Function ((&)) -import Data.Text (Text, pack) -import Effectful (Eff, (:>), runEff) -import Effectful.Concurrent (Concurrent, runConcurrent, threadDelay) -import Effectful.Log (LogLevel(LogAttention, LogInfo), runLog) -import Effectful.Reader.Static (Reader, asks, runReader) -import Effectful.Resource (runResource) -import Effectful.State.Static.Local (evalState) -import Hsm.Core.App (launch) -import Hsm.Core.Env (deriveFromYaml) -import Hsm.Core.Fsm qualified as F -import Hsm.Core.Zmq.Server (runServer, send) -import Streamly.Data.Stream (Stream, repeatM) -import System.IO.Echo (withoutInputEcho) - -data Env = Env - { name :: Text - , pubEp :: Text - , period :: Int - , pulses :: Int - } - -$(deriveFromYaml ''Env) - -pulse :: (Concurrent :> es, Reader Env :> es) => Stream (Eff es) () -pulse = repeatM $ asks period >>= threadDelay - -stateRun :: F.FsmState () Int Env Int -stateRun = F.FsmState "run" action - where - action _ env sta = - if sta < env.pulses - then next - else exit - where - next = - F.FsmOutput - (Just $ F.FsmResult sta (succ sta) stateRun) - [(LogInfo, "Sending pulse #" <> pack (show sta))] - exit = - F.FsmOutput - Nothing - [(LogAttention, "Reached " <> pack (show env.pulses) <> " pulses")] - --- Dummy pulser service: --- Proof of concept. Publishes a "pulse" through ZMQ at a set interval. -main :: IO () -main = - launch @Env "dummy-pulser" withoutInputEcho $ \env logger level -> - (pulse & F.fsm @_ @_ @Env @Int & send @Env @_ @Int) - & runServer @Env - & evalState @Int 1 - & evalState stateRun - & runConcurrent - & runLog env.name logger level - & runReader env - & runResource - & runEff diff --git a/hsm-dummy-pulser/hsm-dummy-pulser.cabal b/hsm-dummy-pulser/hsm-dummy-pulser.cabal deleted file mode 100644 index 747f62c..0000000 --- a/hsm-dummy-pulser/hsm-dummy-pulser.cabal +++ /dev/null @@ -1,25 +0,0 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev -name: hsm-dummy-pulser -version: 0.1.0.0 - -executable dummy-pulser - build-depends: - , base - , echo - , effectful - , hsm-core - , log-effectful - , resourcet-effectful - , streamly-core - , text - - main-is: Main.hs - ghc-options: -Wall -Wunused-packages - - if !arch(x86_64) - ghc-options: -optl=-mno-fix-cortex-a53-835769 - - default-language: GHC2021 diff --git a/hsm-dummy-receiver/Main.hs b/hsm-dummy-receiver/Main.hs deleted file mode 100644 index 451e9c4..0000000 --- a/hsm-dummy-receiver/Main.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -import Data.Function ((&)) -import Data.Text (Text, pack) -import Effectful (Eff, (:>), runEff) -import Effectful.Log (Log, localDomain, logInfo_, runLog) -import Effectful.Reader.Static (runReader) -import Effectful.Resource (runResource) -import Hsm.Core.App (launch) -import Hsm.Core.Env (deriveFromYaml) -import Hsm.Core.Zmq.Client (receive, runClient) -import Streamly.Data.Fold qualified as S (drain) -import Streamly.Data.Stream qualified as S (Stream, fold, mapM) -import System.IO.Echo (withoutInputEcho) - -data Env = Env - { name :: Text - , subEps :: [Text] - , topics :: [Text] - } - -$(deriveFromYaml ''Env) - -handle :: Log :> es => S.Stream (Eff es) Int -> Eff es () -handle = S.fold S.drain . S.mapM handler - where - handler = - localDomain "receiver" - . logInfo_ - . mappend "Received pulse #" - . pack - . show - --- Dummy receiver service: --- Proof of concept. Listens for "pulses" through ZMQ and logs each time one --- is received. -main :: IO () -main = - launch @Env "dummy-receiver" withoutInputEcho $ \env logger level -> - (receive & handle) - & runClient @Env - & runLog env.name logger level - & runReader env - & runResource - & runEff diff --git a/hsm-dummy-receiver/hsm-dummy-receiver.cabal b/hsm-dummy-receiver/hsm-dummy-receiver.cabal deleted file mode 100644 index 9738bbe..0000000 --- a/hsm-dummy-receiver/hsm-dummy-receiver.cabal +++ /dev/null @@ -1,25 +0,0 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev -name: hsm-dummy-receiver -version: 0.1.0.0 - -executable dummy-receiver - build-depends: - , base - , echo - , effectful-core - , hsm-core - , log-effectful - , resourcet-effectful - , streamly-core - , text - - main-is: Main.hs - ghc-options: -Wall -Wunused-packages - - if !arch(x86_64) - ghc-options: -optl=-mno-fix-cortex-a53-835769 - - default-language: GHC2021 diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs index bc08ef5..31b73d9 100644 --- a/hsm-gpio/Hsm/GPIO.hs +++ b/hsm-gpio/Hsm/GPIO.hs @@ -1,120 +1,129 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Hsm.GPIO - ( GPIO(..) - , GPIOEffect - , toggle + ( GPIOPin (..) + , GPIO + , setPins + , setAllPins , runGPIO - ) where + ) +where -import Data.Aeson (FromJSON) -import Data.Kind (Type) -import Data.List (intercalate) -import Data.Set (Set, toList, unions) -import Data.String (IsString) -import Data.Text (Text, pack) -import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>)) -import Effectful.Dispatch.Static qualified as E -import Effectful.Exception (finally) -import Effectful.Log (Log, localDomain, logTrace_) -import GHC.Generics (Generic) -import Hsm.Core.Log (flushLogger) -import System.Process (callCommand) +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 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 + , LineValue + , chipClose + , chipOpen + , chipRequestLines + , inactive + , lineConfigAddLineSettings + , lineConfigFree + , lineConfigNew + , lineRequestRelease + , lineRequestSetValue + , lineRequestSetValues + , lineSettingsFree + , lineSettingsNew + , lineSettingsSetDirection + , lineSettingsSetOutputValue + , output + , requestConfigFree + , requestConfigNew + , requestConfigSetConsumer + ) +import Hsm.Log (Log, Severity (Info, Trace), logMsg) +import Prelude hiding (replicate) --- Monofunctional GPIO pins -data GPIO - = GPIO5 - | GPIO6 - | GPIO16 - | GPIO17 - | GPIO22 - | GPIO23 - | GPIO24 - | GPIO25 - | GPIO26 - | GPIO27 - deriving (Eq, FromJSON, Generic, Ord, Read, Show) +$(makeSerial "GPIO" "Pin" "pinLine" ''CUInt $ [2 .. 17] <> [20 .. 27]) -data GPIOEffect key a b +allPins :: [GPIOPin] +allPins = [minBound .. maxBound] -type instance DispatchOf (GPIOEffect key) = Static E.WithSideEffects +allLines :: [CUInt] +allLines = pinLine <$> allPins --- Effect state is a mapping function from type `key` to a `Set` of GPIO pins. --- This enables `key`s of any type to control many pins simultaneously. Using --- a function (instead of `Data.Map`) ensures all keys map to pins, given the --- provided function is total. -newtype instance E.StaticRep (GPIOEffect (key :: Type)) = - GPIOEffect (key -> Set GPIO) +pinCount :: Int +pinCount = length allPins -domain :: Text -domain = "gpio" +data GPIO (a :: * -> *) (b :: *) -stateStr :: IsString a => Bool -> a -stateStr True = "on" -stateStr False = "off" +type instance DispatchOf GPIO = Static WithSideEffects --- To control the pins, I use a subprocess call to `gpioset`. In the future --- I'd prefer wrapping `libgpiod` directly. It looks like no one has created a --- C wrapper yet, I might do it if I get bored. :) -gpioset :: Log :> es => Bool -> Set GPIO -> [Int] -> Eff es () -gpioset state gpios periods = do - localDomain domain $ logTrace_ $ "Calling command: " <> pack command - E.unsafeEff_ $ callCommand command - where - lineArg gpio = show gpio <> "=" <> stateStr state <> " " - command = - "gpioset -t" - <> intercalate "," (show <$> periods) - <> " " - <> concatMap lineArg (toList gpios) +newtype instance StaticRep GPIO + = GPIO (Ptr LineRequest) -logReport :: - (Log :> es, Show key) => Bool -> key -> [Int] -> Set GPIO -> Eff es () -logReport state key periods gpios = do - localDomain domain $ logTrace_ report - flushLogger - where - report = - "Setting pins " - <> pack (show gpios) - <> " mapped to key " - <> pack (show key) - <> " to state " - <> pack (show state) - <> " using periods " - <> pack (show periods) +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 + unsafeEff_ . forM_ pins $ \pin -> lineRequestSetValue lineRequest (pinLine pin) lineValue -toggle :: - (GPIOEffect key :> es, Log :> es, Show key) - => Bool - -> key - -> [Int] - -> Eff es () -toggle state key periods = do - GPIOEffect mapper <- E.getStaticRep - set $ mapper key - where - set gpios = do - logReport state key periods gpios - gpioset state gpios periods +setAllPins :: (GPIO :> es, Log "gpio" :> es) => LineValue -> Eff es () +setAllPins lineValue = do + GPIO lineRequest <- getStaticRep + logMsg Trace $ "Setting all pins " <> show allPins <> " to " <> show lineValue + unsafeEff_ . unsafeWith (replicate pinCount lineValue) $ void . lineRequestSetValues lineRequest -runGPIO :: - (IOE :> es, Log :> es, Bounded key, Enum key) - => (key -> Set GPIO) - -> Eff (GPIOEffect key : es) a - -> Eff es a -runGPIO mapper action = - E.evalStaticRep (GPIOEffect mapper) $ finally action release +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 - gpios = unions $ mapper <$> [minBound .. maxBound] - endReport = - "Setting all mapped pins " - <> pack (show gpios) - <> " to state " - <> stateStr False - release = do - localDomain domain $ logTrace_ endReport - gpioset False gpios [0] + 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.hsc b/hsm-gpio/Hsm/GPIO/FFI.hsc new file mode 100644 index 0000000..d8b0f47 --- /dev/null +++ b/hsm-gpio/Hsm/GPIO/FFI.hsc @@ -0,0 +1,116 @@ +{-# LANGUAGE CApiFFI #-} + +-- FFI bindings to `libgpiod` for direct GPIO hardware access. +-- +-- Exposes only the minimal required subset of `libgpiod` functionality used by +-- this project. The bindings are suitable for low-level hardware control. +-- +-- Future work could expand this into a comprehensive `gpiod` binding package. +module Hsm.GPIO.FFI + ( chipOpen + , chipClose + , input + , output + , LineValue + , active + , inactive + , lineSettingsNew + , lineSettingsFree + , lineSettingsSetDirection + , lineSettingsSetOutputValue + , lineConfigNew + , lineConfigFree + , lineConfigAddLineSettings + , requestConfigNew + , requestConfigFree + , requestConfigSetConsumer + , LineRequest + , chipRequestLines + , lineRequestRelease + , lineRequestSetValue + , lineRequestSetValues + ) +where + +import Foreign.C.String (CString) +import Foreign.C.Types (CInt (CInt), CSize (CSize), CUInt (CUInt)) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable) + +data Chip + +foreign import capi safe "gpiod.h gpiod_chip_open" + chipOpen :: CString -> IO (Ptr Chip) + +foreign import capi safe "gpiod.h gpiod_chip_close" + chipClose :: Ptr Chip -> IO () + +data LineSettings + +newtype LineDirection + = LineDirection CInt + deriving Show + +foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT" + input :: LineDirection + +foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT" + output :: LineDirection + +newtype LineValue + = LineValue CInt + deriving (Show, Storable) + +foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE" + active :: LineValue + +foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE" + inactive :: LineValue + +foreign import capi safe "gpiod.h gpiod_line_settings_new" + lineSettingsNew :: IO (Ptr LineSettings) + +foreign import capi safe "gpiod.h gpiod_line_settings_free" + lineSettingsFree :: Ptr LineSettings -> IO () + +foreign import capi safe "gpiod.h gpiod_line_settings_set_direction" + lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt + +foreign import capi safe "gpiod.h gpiod_line_settings_set_output_value" + lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt + +data LineConfig + +foreign import capi safe "gpiod.h gpiod_line_config_new" + lineConfigNew :: IO (Ptr LineConfig) + +foreign import capi safe "gpiod.h gpiod_line_config_free" + lineConfigFree :: Ptr LineConfig -> IO () + +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 capi safe "gpiod.h gpiod_request_config_new" + requestConfigNew :: IO (Ptr RequestConfig) + +foreign import capi safe "gpiod.h gpiod_request_config_free" + requestConfigFree :: Ptr RequestConfig -> IO () + +foreign import capi safe "gpiod.h gpiod_request_config_set_consumer" + requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO () + +data LineRequest + +foreign import capi safe "gpiod.h gpiod_chip_request_lines" + chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest) + +foreign import capi safe "gpiod.h gpiod_line_request_release" + lineRequestRelease :: Ptr LineRequest -> IO () + +foreign import capi safe "gpiod.h gpiod_line_request_set_value" + lineRequestSetValue :: Ptr LineRequest -> CUInt -> 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 8ff3e13..ba538db 100644 --- a/hsm-gpio/hsm-gpio.cabal +++ b/hsm-gpio/hsm-gpio.cabal @@ -1,21 +1,22 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev +cabal-version: 3.8 +author: Paul Oliver <contact@pauloliver.dev> name: hsm-gpio version: 0.1.0.0 library build-depends: - , aeson , base - , containers , effectful-core + , effectful-plugin , hsm-core - , log-effectful - , process - , text + , hsm-log + , transformers + , vector + default-language: GHC2024 exposed-modules: Hsm.GPIO - ghc-options: -Wall -Wunused-packages - default-language: GHC2021 + ghc-options: + -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages + -ddump-splices -fplugin=Effectful.Plugin + + other-modules: Hsm.GPIO.FFI diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs new file mode 100644 index 0000000..99e5b7c --- /dev/null +++ b/hsm-log/Hsm/Log.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Hsm.Log + ( Severity (Attention, Info, Trace) + , Log + , 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 + , 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, Read, Show) + +coloredShow :: Severity -> String +coloredShow Attention = red "ATTENTION" +coloredShow Info = green "INFO" +coloredShow Trace = blue "TRACE" + +data Log (d :: Symbol) (a :: * -> *) (b :: *) + +type instance DispatchOf (Log d) = Static WithSideEffects + +newtype instance StaticRep (Log d) + = Log Severity + +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 = 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 + => Severity + -> Eff (Log d : es) a + -> Eff es a +runLog = evalStaticRep . Log + +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 (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where + type Insert '[] es = es + runLogs = const id + runLogsOpt = const id + +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 @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..0e00b32 --- /dev/null +++ b/hsm-log/Hsm/Log/Options.hs @@ -0,0 +1,76 @@ +{-# 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 new file mode 100644 index 0000000..f20d201 --- /dev/null +++ b/hsm-log/hsm-log.cabal @@ -0,0 +1,25 @@ +cabal-version: 3.8 +author: Paul Oliver <contact@pauloliver.dev> +name: hsm-log +version: 0.1.0.0 + +library + build-depends: + , base + , effectful-core + , effectful-plugin + , generic-data-functions + , iso8601-time + , optparse-applicative + , template-haskell + , text-ansi + , time + + default-language: GHC2024 + 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-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs new file mode 100644 index 0000000..bc31fbc --- /dev/null +++ b/hsm-pwm/Hsm/PWM.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- Raspberry Pi 5 PWM control (sysfs interface) +-- +-- Requires: +-- - `dtoverlay=pwm-2chan` in `/boot/config.txt` +-- - UDEV rules for non-root access +-- +-- Supports 2 active PWM channels. For details see: +-- - PWM Configuration: https://www.pi4j.com/blog/2024/20240423_pwm_rpi5/#modify-configtxt +-- - SysFS Reference: https://forums.raspberrypi.com/viewtopic.php?t=359251 +-- - UDEV Setup: https://forums.raspberrypi.com/viewtopic.php?t=316514 +module Hsm.PWM + ( PWMChannel (..) + , PWM + , setCycleDuration + , runPWM + ) +where + +import Control.Concurrent (threadDelay) +import Control.Monad (forM_) +import Control.Monad.Loops (untilM_) +import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>)) +import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, unsafeEff_) +import Effectful.Exception (bracket_) +import Hsm.Core.Serial (makeSerial) +import Hsm.Log (Log, Severity (Info, Trace), logMsg) +import System.FilePath ((</>)) +import System.Posix.Files (fileAccess) + +$(makeSerial "PWM" "Channel" "channelIndex" ''Int [1, 2]) + +data PWM (a :: * -> *) (b :: *) + +type instance DispatchOf PWM = Static WithSideEffects + +newtype instance StaticRep PWM + = PWM () + +chipPath :: FilePath +chipPath = "/sys/class/pwm/pwmchip0" + +channelPath :: PWMChannel -> FilePath +channelPath channel = chipPath </> "pwm" <> show (channelIndex channel) + +enablePath :: PWMChannel -> FilePath +enablePath channel = channelPath channel </> "enable" + +periodPath :: PWMChannel -> FilePath +periodPath channel = channelPath channel </> "period" + +dutyCyclePath :: PWMChannel -> FilePath +dutyCyclePath channel = channelPath channel </> "duty_cycle" + +setEnable :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Bool -> Eff es () +setEnable channel enable = do + logMsg Trace $ "Setting " <> enablePath channel <> " to " <> show enable + unsafeEff_ . writeFile (enablePath channel) . show $ fromEnum enable + +setPeriod :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Int -> Eff es () +setPeriod channel period = do + logMsg Trace $ "Setting " <> periodPath channel <> " to " <> show period + unsafeEff_ . writeFile (periodPath channel) $ show period + +setDutyCycle :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Int -> Eff es () +setDutyCycle channel dutyCycle = do + logMsg Trace $ "Setting " <> dutyCyclePath channel <> " to " <> show dutyCycle + unsafeEff_ . writeFile (dutyCyclePath channel) $ show dutyCycle + +-- Sets the PWM cycle duration (period) for a channel +-- +-- - Special case: A duration of 0 halts PWM output +-- - Normal operation: +-- 1. Zero the duty cycle first to avoid 'Invalid argument' errors +-- (period cannot be smaller than current duty cycle) +-- 2. Update period +-- 3. Set default 50% duty cycle +-- 4. Re-enable output +setCycleDuration :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Int -> Eff es () +setCycleDuration channel 0 = do + logMsg Trace $ "Halting PWM signals on channel " <> show channel + setEnable channel False +setCycleDuration channel cycleDuration = do + logMsg Trace $ "Setting cycle duration on channel " <> show channel <> " to " <> show cycleDuration + setEnable channel False + setDutyCycle channel 0 + setPeriod channel cycleDuration + setDutyCycle channel $ cycleDuration `div` 2 + setEnable channel True + +runPWM :: (IOE :> es, Log "pwm" :> es) => Eff (PWM : es) a -> Eff es a +runPWM = evalStaticRep (PWM ()) . bracket_ pwmAlloc pwmDealloc + where + exportPath = chipPath </> "export" + unexportPath = chipPath </> "unexport" + -- Blocks until the PWM sysfs file becomes writable + -- + -- Handles the race condition caused by: + -- 1. Sysfs file creation + -- 2. UDEV rules (async `chown` to `pwm` group) + -- + -- Polls permissions with 1ms delay between checks. + waitWritable path = do + logMsg Info $ "Waiting for " <> path <> " to become writable" + liftIO . untilM_ (threadDelay 1000) $ fileAccess path False True False + allChannels = [minBound .. maxBound] + pwmAlloc = do + waitWritable exportPath + waitWritable unexportPath + forM_ allChannels $ \channel -> do + logMsg Info $ "Exporting channel " <> show channel <> " on chip " <> chipPath + liftIO . writeFile exportPath $ show (channelIndex channel) + waitWritable $ enablePath channel + waitWritable $ periodPath channel + waitWritable $ dutyCyclePath channel + setCycleDuration channel 0 + pwmDealloc = + forM_ allChannels $ \channel -> do + setEnable channel False + logMsg Info $ "Unexporting channel " <> show channel <> " on chip " <> chipPath + liftIO . writeFile unexportPath $ show (channelIndex channel) diff --git a/hsm-pwm/hsm-pwm.cabal b/hsm-pwm/hsm-pwm.cabal new file mode 100644 index 0000000..808c7cb --- /dev/null +++ b/hsm-pwm/hsm-pwm.cabal @@ -0,0 +1,21 @@ +cabal-version: 3.8 +author: Paul Oliver <contact@pauloliver.dev> +name: hsm-pwm +version: 0.1.0.0 + +library + build-depends: + , base + , effectful-core + , effectful-plugin + , filepath + , hsm-core + , hsm-log + , monad-loops + , unix + + default-language: GHC2024 + exposed-modules: Hsm.PWM + ghc-options: + -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages + -ddump-splices -fplugin=Effectful.Plugin diff --git a/hsm-repl/Hsm/Repl.hs b/hsm-repl/Hsm/Repl.hs new file mode 100644 index 0000000..00012c5 --- /dev/null +++ b/hsm-repl/Hsm/Repl.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TypeFamilies #-} + +module Hsm.Repl + ( Repl + , repl + , runRepl + ) +where + +import Control.Monad (forM_) +import Data.Typeable (Proxy (Proxy), Typeable, typeRep) +import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>)) +import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_) +import Effectful.Exception (bracket) +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) + +data Repl (p :: Symbol) (ms :: [Symbol]) (t :: *) (a :: * -> *) (b :: *) + +type instance DispatchOf (Repl p ms t) = Static WithSideEffects + +newtype instance StaticRep (Repl p ms t) + = Repl InputState + +repl + :: forall p ms t es + . (KnownSymbol p, KnownSymbols ms, Log "repl" :> es, Repl p ms t :> es, Show t, Typeable t) + => Eff es (Maybe t) +repl = query >>= maybe (return Nothing) parse + where + query = do + Repl inputState <- getStaticRep + logMsg Trace $ "Expecting a value of type: " <> show (typeRep $ Proxy @t) + unsafeEff_ . queryInput inputState . handleInterrupt (return Nothing) . withInterrupt . getInputLine . blue $ + symbolVal (Proxy @p) + parse string = do + logMsg Trace $ "Parsing string: " <> string + eitherValue <- + unsafeEff_ . runInterpreter $ do + setImports $ symbolVals @ms + interpret string as + case eitherValue of + Right value -> do + logMsg Trace $ "Parsed value: " <> show value + return $ Just value + Left (WontCompile errors) -> do + forM_ errors $ logMsg Attention . errMsg + repl + Left err -> do + logMsg Attention $ show err + repl + +runRepl + :: forall p ms t es a + . (IOE :> es, Log "repl" :> es) + => Eff (Repl p ms t : es) a + -> Eff es a +runRepl action = bracket inputStateAlloc inputStateDealloc $ \inputState -> evalStaticRep (Repl inputState) action + where + inputStateAlloc = do + logMsg Info "Initializing input" + liftIO $ initializeInput defaultSettings + inputStateDealloc inputState = do + logMsg Info "Cancelling input" + liftIO $ cancelInput inputState diff --git a/hsm-repl/Test/Repl.hs b/hsm-repl/Test/Repl.hs new file mode 100644 index 0000000..7d1431c --- /dev/null +++ b/hsm-repl/Test/Repl.hs @@ -0,0 +1,8 @@ +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 diff --git a/hsm-repl/hsm-repl.cabal b/hsm-repl/hsm-repl.cabal new file mode 100644 index 0000000..5d9a794 --- /dev/null +++ b/hsm-repl/hsm-repl.cabal @@ -0,0 +1,44 @@ +cabal-version: 3.8 +author: Paul Oliver <contact@pauloliver.dev> +name: hsm-repl +version: 0.1.0.0 + +library + build-depends: + , base + , effectful-core + , effectful-plugin + , generic-data-functions + , haskeline + , hint + , hsm-log + , text-ansi + + default-language: GHC2024 + exposed-modules: Hsm.Repl + ghc-options: + -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages + -fplugin=Effectful.Plugin + +executable test-repl + build-depends: + , base + , effectful-core + , effectful-plugin + , generic-data-functions + , haskeline + , hint + , hsm-log + , monad-loops + , text-ansi + + default-language: GHC2024 + ghc-options: + -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages + -fplugin=Effectful.Plugin + + if !arch(x86_64) + ghc-options: -optl=-mno-fix-cortex-a53-835769 + + main-is: Test/Repl.hs + other-modules: Hsm.Repl diff --git a/hsm-status/Hsm/Status/Error.hs b/hsm-status/Hsm/Status/Error.hs deleted file mode 100644 index 2853d6b..0000000 --- a/hsm-status/Hsm/Status/Error.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - -module Hsm.Status.Error - ( Error(Error) - ) where - -import Data.Binary (Binary) -import Data.Text (Text) -import GHC.Generics (Generic) - -data Error = - Error Int Text - deriving (Binary, Generic, Show) diff --git a/hsm-status/Main.hs b/hsm-status/Main.hs deleted file mode 100644 index 6220474..0000000 --- a/hsm-status/Main.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -import Data.Function ((&)) -import Data.Set (Set, singleton) -import Data.Text (Text, pack) -import Effectful (Eff, (:>), runEff) -import Effectful.Log (Log, LogLevel(LogAttention), runLog) -import Effectful.Reader.Static (Reader, ask, runReader) -import Effectful.Resource (runResource) -import Effectful.State.Static.Local (evalState) -import Hsm.Core.App (launch) -import Hsm.Core.Env (deriveFromYaml) -import Hsm.Core.Fsm qualified as F -import Hsm.Core.Zmq.Client (poll, runClient) -import Hsm.GPIO (GPIO, GPIOEffect, runGPIO, toggle) -import Hsm.Status.Error (Error(Error)) -import Streamly.Data.Fold qualified as S (drain) -import Streamly.Data.Stream qualified as S (Stream, fold, mapM) -import System.IO.Echo (withoutInputEcho) - -data Env = Env - { name :: Text - , gpioOk :: GPIO - , gpioError :: GPIO - , period :: Int - , subEps :: [Text] - , topics :: [Text] - } - -$(deriveFromYaml ''Env) - -result :: - Bool - -> F.FsmState [Error] Bool Env () - -> [Error] - -> F.FsmOutput [Error] Bool Env () -result sta next es = - F.FsmOutput (Just $ F.FsmResult sta () next) (logError <$> es) - where - logError (Error code msg) = - ( LogAttention - , "Error received with code " - <> pack (show code) - <> " and message: " - <> msg) - -stateOk :: F.FsmState [Error] Bool Env () -stateOk = - F.FsmState "ok" $ \msg _ _ -> - if null msg - then result True stateOk msg - else result False stateError msg - -stateError :: F.FsmState [Error] Bool Env () -stateError = F.FsmState "error" $ \msg _ _ -> result False stateError msg - -handle :: - (GPIOEffect Bool :> es, Log :> es, Reader Env :> es) - => S.Stream (Eff es) Bool - -> Eff es () -handle = S.fold S.drain . S.mapM handler - where - handler sta = do - env <- ask @Env - toggle False sta [env.period, env.period, 0] - -mapper :: Env -> Bool -> Set GPIO -mapper env True = singleton env.gpioOk -mapper env False = singleton env.gpioError - --- Status service blinks a GPIO pin periodically and listens for error --- messages. If an error is received it switches to a different pin. -main :: IO () -main = - launch "status" withoutInputEcho $ \env logger level -> - (poll @_ @Error & F.fsm @_ @_ @Env @() & handle) - & runClient @Env - & runGPIO (mapper env) - & evalState () - & evalState stateOk - & runLog env.name logger level - & runReader env - & runResource - & runEff diff --git a/hsm-status/hsm-status.cabal b/hsm-status/hsm-status.cabal deleted file mode 100644 index 64528bd..0000000 --- a/hsm-status/hsm-status.cabal +++ /dev/null @@ -1,39 +0,0 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev -name: hsm-status -version: 0.1.0.0 - -library - build-depends: - , base - , binary - , text - - exposed-modules: Hsm.Status.Error - ghc-options: -Wall -Wunused-packages - default-language: GHC2021 - -executable status - build-depends: - , base - , binary - , containers - , echo - , effectful-core - , hsm-core - , hsm-gpio - , log-effectful - , resourcet-effectful - , streamly-core - , text - - main-is: Main.hs - other-modules: Hsm.Status.Error - ghc-options: -Wall -Wunused-packages - - if !arch(x86_64) - ghc-options: -optl=-mno-fix-cortex-a53-835769 - - default-language: GHC2021 diff --git a/hsm-web/Hsm/Web.hs b/hsm-web/Hsm/Web.hs new file mode 100644 index 0000000..b8f8881 --- /dev/null +++ b/hsm-web/Hsm/Web.hs @@ -0,0 +1,59 @@ +{-# 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..6cbfa31 --- /dev/null +++ b/hsm-web/Main.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.Function ((&)) +import Effectful (runEff) +import Hsm.Cam (runCam) +import Hsm.Core.App (bootstrapAppNoEcho) +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 = bootstrapAppNoEcho parser "Launch HsMouse Web Server" $ \opts -> runServer & runWeb & runCam & runLogsOpt @Options @Loggers opts & runEff 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/servconf.yaml b/servconf.yaml deleted file mode 100644 index a014ade..0000000 --- a/servconf.yaml +++ /dev/null @@ -1,41 +0,0 @@ -command: - name: command - pubEp: tcp://0.0.0.0:10000 -dummy-blinker: - gpio: - - GPIO17 - - GPIO22 - - GPIO27 - name: blinker - period: 1000 -dummy-fail: - alive: 1000000 - name: fail - pubEp: tcp://0.0.0.0:10002 -dummy-poller: - name: poller - period: 3000000 - subEps: - - tcp://0.0.0.0:10001 - topics: - - pulser -dummy-pulser: - name: pulser - period: 1000000 - pubEp: tcp://0.0.0.0:10001 - pulses: 10 -dummy-receiver: - name: receiver - subEps: - - tcp://0.0.0.0:10001 - topics: - - pulser -status: - gpioError: GPIO17 - gpioOk: GPIO22 - name: status - period: 1000 - subEps: - - tcp://0.0.0.0:10002 - topics: - - fail @@ -1,15 +1,12 @@ -allow-newer: true extra-deps: - - log-effectful-1.0.1.0 - resourcet-effectful-1.0.1.0 + - typelits-printf-0.3.0.0 packages: - - hsm-command + - hsm-cam - hsm-core - - hsm-dummy-blinker - - hsm-dummy-fail - - hsm-dummy-poller - - hsm-dummy-pulser - - hsm-dummy-receiver - hsm-gpio - - hsm-status -snapshot: lts-23.3 + - hsm-log + - hsm-pwm + - hsm-repl + - hsm-web +resolver: lts-24.9 diff --git a/stack.yaml.lock b/stack.yaml.lock index aa298d4..d3bf022 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,22 +5,22 @@ packages: - completed: - hackage: log-effectful-1.0.1.0@sha256:79d1c821db1c1d95cf109f813f13a2588e45dbacb5f797eefc200ff7a5984923,2466 - pantry-tree: - sha256: 5ab7c6b553ea50ce7b6218e86db9ff3632b0482dd00aaf749ebece93b968e0ca - size: 326 - original: - hackage: log-effectful-1.0.1.0 -- completed: hackage: resourcet-effectful-1.0.1.0@sha256:13f94c9832d0d1573abbabcddc5c3aa3c341973d1d442445795593e355e7803e,2115 pantry-tree: sha256: ef0db7bdeca5df1e722958cf5c8f3205ed5bf92b111e0fbc5d1a3c592d1c210e size: 283 original: hackage: resourcet-effectful-1.0.1.0 +- completed: + hackage: typelits-printf-0.3.0.0@sha256:47f3d044056546f5c027db53deb6412dbf455c9dcfb8cbb0637a83692906fc6e,2111 + pantry-tree: + sha256: bdda47a6cdfc18b1ad74f9c16432a411909fa65147fe0f8a91b09a02a442751d + size: 702 + original: + hackage: typelits-printf-0.3.0.0 snapshots: - completed: - sha256: dd89d2322cb5af74c6ab9d96c0c5f6c8e6653e0c991d619b4bb141a49cb98668 - size: 679282 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/3.yaml - original: lts-23.3 + sha256: 188228e10dbb5b533bae584049b112e72000902e64b17348679a69f92fbc0d32 + size: 726076 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/9.yaml + original: lts-24.9 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" diff --git a/sysconf/98-gpiod.rules b/sysconf/98-gpiod.rules new file mode 100644 index 0000000..a7275d9 --- /dev/null +++ b/sysconf/98-gpiod.rules @@ -0,0 +1 @@ +SUBSYSTEM=="gpio", KERNEL=="gpiochip*", GROUP="gpiod", MODE="0660" diff --git a/sysconf/99-pwm.rules b/sysconf/99-pwm.rules new file mode 100644 index 0000000..59ba681 --- /dev/null +++ b/sysconf/99-pwm.rules @@ -0,0 +1,14 @@ +# Grants 'pwm' group RW access to Raspberry Pi PWM sysfs interfaces +# +# Handles both: +# - Standard /sys/class/pwm paths +# - RPi5-specific PCIe PWM controllers (/sys/devices/platform/axi/...) +# +# Note: For race-free operation, check file writability (not just existence) +# using `access(2)` before attempting operations. +SUBSYSTEM=="pwm*", PROGRAM="/bin/sh -c ' \ + chown -R root:pwm /sys/class/pwm ; \ + chmod -R 770 /sys/class/pwm ; \ + chown -R root:pwm /sys/devices/platform/axi/1000120000.pcie/*.pwm/pwm/pwmchip* ; \ + chmod -R 770 /sys/devices/platform/axi/1000120000.pcie/*.pwm/pwm/pwmchip* ; \ +'" diff --git a/sysconf/config.txt b/sysconf/config.txt new file mode 100644 index 0000000..f9ff6db --- /dev/null +++ b/sysconf/config.txt @@ -0,0 +1,60 @@ +# For more options and information see: +# https://www.raspberrypi.com/documentation/computers/config_txt.html + +# Some settings may impact device functionality. See link above for details + +initramfs initramfs-linux.img followkernel + +# Uncomment some or all of these to enable the optional hardware interfaces +#dtparam=i2c_arm=on +#dtparam=i2s=on +#dtparam=spi=on + +# Additional overlays and parameters are documented +# /boot/overlays/README + +# Automatically load overlays for detected cameras +camera_auto_detect=1 + +# Automatically load overlays for detected DSI displays +display_auto_detect=1 + +# Enable DRM VC4 V3D driver +dtoverlay=vc4-kms-v3d +max_framebuffers=2 + +# Don't have the firmware create an initial video= setting in cmdline.txt. +# Use the kernel's default instead. +disable_fw_kms_setup=1 + +# Disable compensation for displays with overscan +disable_overscan=1 + +# Uncomment if hdmi display is not detected and composite is being output +#hdmi_force_hotplug=1 + +# Uncomment if you want to disable wifi or bluetooth respectively +#dtoverlay=disable-wifi +dtoverlay=disable-bt + +# Uncomment this to enable infrared communication. +#dtoverlay=gpio-ir,gpio_pin=17 +#dtoverlay=gpio-ir-tx,gpio_pin=18 + +# Run as fast as firmware / board allows +arm_boost=1 + +# Set GPIO pins to output / low state on boot +gpio=0-27=op,dl + +[cm4] +# Enable host mode on the 2711 built-in XHCI USB controller. +# This line should be removed if the legacy DWC2 controller is required +# (e.g. for USB device mode) or if USB support is not required. +otg_mode=1 + +[cm5] +dtoverlay=dwc2,dr_mode=host + +[all] +dtoverlay=pwm-2chan |