diff options
54 files changed, 1028 insertions, 1346 deletions
@@ -1,2 +1 @@ **/.stack-work/ -.hsm_command_history @@ -1,52 +1,62 @@ # 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. + +## 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 `stack build` to compile the libraries and executables + +> Note: You may need to install system dependencies on your host first (e.g., +> `libgpiod`, etc.) diff --git a/hsm-bin/Test/Drive.hs b/hsm-bin/Test/Drive.hs new file mode 100644 index 0000000..7a58c11 --- /dev/null +++ b/hsm-bin/Test/Drive.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.IO.Region (region) +import Control.Monad.Loops (whileJust_) +import Hsm.Drive (DriveEnv, drive, driveEnvDefault) +import Hsm.GPIO (allocateGPIO) +import Hsm.PWM (allocatePWM) +import Hsm.Readline (allocateReadline, readline) + +newtype Env = Env + { driveEnv :: DriveEnv + } + +main :: IO () +main = + region $ \ioRegion -> do + lineRequest <- allocateGPIO ioRegion "test-status" + pwmHandle <- allocatePWM ioRegion $ const 0 + handle <- allocateReadline ioRegion + whileJust_ (readline handle) + $ drive lineRequest pwmHandle + $ Env driveEnvDefault diff --git a/hsm-bin/Test/Status.hs b/hsm-bin/Test/Status.hs new file mode 100644 index 0000000..62ba4fa --- /dev/null +++ b/hsm-bin/Test/Status.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.IO.Region (region) +import Control.Monad.Loops (whileJust_) +import Hsm.GPIO (allocateGPIO) +import Hsm.Readline (allocateReadline, readline) +import Hsm.Status (StatusEnv, status, statusEnvDefault) + +newtype Env = Env + { statusEnv :: StatusEnv + } + +main :: IO () +main = + region $ \ioRegion -> do + lineRequest <- allocateGPIO ioRegion "test-status" + handle <- allocateReadline ioRegion + whileJust_ (readline handle) $ status lineRequest $ Env statusEnvDefault diff --git a/hsm-bin/hsm-bin.cabal b/hsm-bin/hsm-bin.cabal new file mode 100644 index 0000000..de6e1a5 --- /dev/null +++ b/hsm-bin/hsm-bin.cabal @@ -0,0 +1,34 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-bin +version: 0.1.0.0 + +common test-executable + build-depends: + , base + , hsm-gpio + , hsm-readline + , io-region + , monad-loops + + ghc-options: -Wall -Wunused-packages + + if !arch(x86_64) + ghc-options: -optl=-mno-fix-cortex-a53-835769 + + default-language: GHC2021 + +executable test-status + import: test-executable + build-depends: hsm-status + main-is: Test/Status.hs + +executable test-drive + import: test-executable + build-depends: + , hsm-drive + , hsm-pwm + + main-is: Test/Drive.hs diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs new file mode 100644 index 0000000..ef99e82 --- /dev/null +++ b/hsm-cam/Hsm/Cam.hs @@ -0,0 +1,3 @@ +module Hsm.Cam + ( + ) where diff --git a/hsm-cam/Hsm/Cam/Lib.cpp b/hsm-cam/Hsm/Cam/Lib.cpp new file mode 100644 index 0000000..5eda6d7 --- /dev/null +++ b/hsm-cam/Hsm/Cam/Lib.cpp @@ -0,0 +1,11 @@ +#include <string> + +#include "Lib_stub.h" + +void log_msg(const std::string &str) { + logMsg((HsPtr)str.c_str()); +} + +extern "C" void some_c_wrapper() { + log_msg("Hello from C++!"); +} diff --git a/hsm-cam/Hsm/Cam/Lib.hsc b/hsm-cam/Hsm/Cam/Lib.hsc new file mode 100644 index 0000000..4f6dadf --- /dev/null +++ b/hsm-cam/Hsm/Cam/Lib.hsc @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hsm.Cam.Lib + ( someCWrapper + ) where + +import Control.Monad ((>=>)) +import Data.Text (pack) +import Foreign.C.String (CString, peekCString) +import Hsm.Log qualified as L + +foreign export ccall logMsg :: CString -> IO () + +logMsg :: CString -> IO () +logMsg = peekCString >=> L.logMsg ["cam", "lib"] . pack + +foreign import ccall safe "Test.h some_c_wrapper" + someCWrapper :: IO () diff --git a/hsm-cam/hsm-cam.cabal b/hsm-cam/hsm-cam.cabal new file mode 100644 index 0000000..1f732e9 --- /dev/null +++ b/hsm-cam/hsm-cam.cabal @@ -0,0 +1,22 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-cam +version: 0.1.0.0 +extra-source-files: Hsm/Cam/*.cpp + +library + build-depends: + , base + , hsm-log + , text + + exposed-modules: Hsm.Cam + other-modules: Hsm.Cam.Lib + include-dirs: Hsm/Cam + cxx-sources: Hsm/Cam/Lib.cpp + cxx-options: -Wall -Wextra -O2 + ghc-options: -Wall -Wunused-packages + extra-libraries: stdc++ + default-language: GHC2021 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 deleted file mode 100644 index 11759be..0000000 --- a/hsm-core/Hsm/Core/App.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Hsm.Core.App - ( launch - ) 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) - -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 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/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 deleted file mode 100644 index bbdbbb3..0000000 --- a/hsm-core/hsm-core.cabal +++ /dev/null @@ -1,42 +0,0 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev -name: hsm-core -version: 0.1.0.0 - -library - build-depends: - , aeson - , base - , binary - , bytestring - , effectful-core - , log-base - , log-effectful - , monad-loops - , optparse-applicative - , optparse-text - , resourcet-effectful - , streamly-core - , template-haskell - , text - , time - , yaml - , zeromq4-haskell - - 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 - - other-modules: - Hsm.Core.Options - Hsm.Core.Zmq - - ghc-options: -Wall -Wunused-packages - default-language: GHC2021 diff --git a/hsm-drive/Hsm/Drive.hs b/hsm-drive/Hsm/Drive.hs new file mode 100644 index 0000000..3580b5a --- /dev/null +++ b/hsm-drive/Hsm/Drive.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hsm.Drive + ( Speed(..) + , Direction(..) + , Duration + , DriveAction(..) + , DriveEnv(..) + , driveEnvDefault + , drive + ) where + +import Control.Concurrent (threadDelay) +import Control.Exception (AsyncException, handle) +import Control.Monad (forM_) +import Data.Text (pack) +import Data.Typeable (Typeable) +import Foreign.Ptr (Ptr) +import GHC.Records (HasField) +import Hsm.GPIO (GPIO(..), LineRequest, active, inactive, setPins) +import Hsm.Log qualified as L +import Hsm.PWM qualified as P +import System.IO.Echo (withoutInputEcho) + +data Direction + = N + | NE + | E + | SE + | S + | SW + | W + | NW + | RL + | RR + deriving (Read, Show, Typeable) + +data Speed + = SlowXXX + | SlowXX + | SlowX + | Slow + | Fast + | Top + deriving (Read, Show, Typeable) + +type Duration = Float + +data DriveAction + = Move Direction Speed Duration + | Stop Duration + deriving (Read, Show, Typeable) + +-- This function maps a `Speed` value to a corresponding PWM cycle duration. +-- It assumes a stepper motor with 200 steps per revolution, using a 1/16 +-- microstep setting (so actually, 3200 steps per revolution). The returned +-- values represent the duration of a whole PWM cycle in nanoseconds. +cycleDuration :: Speed -> Int +cycleDuration SlowXXX = 8000000000 `div` 3200 -- 1/8 revs/s +cycleDuration SlowXX = 4000000000 `div` 3200 -- 1/4 revs/s +cycleDuration SlowX = 2000000000 `div` 3200 -- 1/2 revs/s +cycleDuration Slow = 1000000000 `div` 3200 -- 1 revs/s +cycleDuration Fast = 500000000 `div` 3200 -- 2 revs/s +cycleDuration Top = 250000000 `div` 3200 -- 4 revs/s + +data DriveEnv = DriveEnv + { pinEnable :: GPIO + , pinDiag1 :: GPIO + , pinDiag2 :: GPIO + , pinDir1 :: GPIO + , pinDir2 :: GPIO + , pinDir3 :: GPIO + , pinDir4 :: GPIO + , pwmChannel :: P.PWMChannel + } + +driveEnvDefault :: DriveEnv +driveEnvDefault = + DriveEnv + { pinEnable = GPIO21 + , pinDiag1 = GPIO20 + , pinDiag2 = GPIO16 + , pinDir1 = GPIO12 + , pinDir2 = GPIO7 + , pinDir3 = GPIO8 + , pinDir4 = GPIO25 + , pwmChannel = P.PWM3 + } + +drive :: + HasField "driveEnv" env DriveEnv + => Ptr LineRequest + -> P.PWMHandle + -> env + -> [DriveAction] + -> IO Bool +drive lineRequest pwmHandle env actions = + withoutInputEcho $ handle handler runActions + where + logMsg = L.logMsg ["drive"] + -- Sets GPIO pins to a desired state + setCycleDuration = P.setCycleDuration pwmHandle env.driveEnv.pwmChannel + setActive pins = setPins lineRequest (pins <*> [env.driveEnv]) active + setInactive pins = setPins lineRequest (pins <*> [env.driveEnv]) inactive + -- Pin assignments for various movement directions, each direction + -- corresponds to a specific set of GPIO pins. + pinsDiag = [pinDiag1, pinDiag2] + pinsDir = [pinDir1, pinDir2, pinDir3, pinDir4] + pinDiagNE = [pinDiag1] + pinDiagSE = [pinDiag2] + pinDiagSW = [pinDiag1] + pinDiagNW = [pinDiag2] + pinsN = [pinDir2, pinDir4] + pinsE = [pinDir1, pinDir2] + pinsS = [pinDir1, pinDir3] + pinsW = [pinDir3, pinDir4] + pinsRL = [pinDir1, pinDir2, pinDir3, pinDir4] + pinsRR = [] + -- Introduces a delay with the duration converted from seconds to + -- microseconds. + runDelay = threadDelay . round . (* 1000000) + -- Ensures that the system is reset to a safe state by setting the PWM + -- cycle duration to zero and deactivating all used motor control pins. + runRelease = do + setCycleDuration 0 + setInactive $ pinsDir <> pinsDiag + -- Handles each movement command and activates the appropriate pins for + -- the requested direction. It also sets the cycle duration for PWM and + -- holds this state for the specified duration. + runAction (Move direction speed duration) = do + case direction of + N -> setActive $ pinsN <> pinsDiag + NE -> setActive $ pinsN <> pinDiagNE + E -> setActive $ pinsE <> pinsDiag + SE -> setActive $ pinsS <> pinDiagSE + S -> setActive $ pinsS <> pinsDiag + SW -> setActive $ pinsS <> pinDiagSW + W -> setActive $ pinsW <> pinsDiag + NW -> setActive $ pinsN <> pinDiagNW + RL -> setActive $ pinsRL <> pinsDiag + RR -> setActive $ pinsRR <> pinsDiag + setCycleDuration $ cycleDuration speed + runDelay duration + runRelease + -- A Stop command causes the system to wait for the specified duration + -- without performing any movement. During this period, the motor drivers + -- remain enabled, effectively applying a brake to the motor by holding it + -- in its current position. + runAction (Stop duration) = runDelay duration + -- Catches any asynchronous exceptions during the execution of commands. + -- If an exception occurs, the system will log the error and ensure that + -- the motors are safely released by calling `runRelease`. + handler exception = do + logMsg + $ "Async exception caught while command was running: " + <> pack (show @AsyncException exception) + runRelease + return False + -- Executes a series of drive actions + runActions = do + setCycleDuration 0 + -- The A4988 motor driver is placed in sleep mode between commands to + -- save power. To wake it up, a 1-microsecond delay is required before + -- sending step commands. For added safety, we wait 1 millisecond to + -- ensure the driver is fully awake. + logMsg "Enabling drivers" + setActive [pinEnable] + logMsg "Allowing drivers to come out of sleep mode" + threadDelay 1000 + forM_ actions $ \action -> do + logMsg $ "Running action " <> pack (show action) + runAction action + logMsg "Disabling drivers" + setInactive [pinEnable] + return True diff --git a/hsm-dummy-pulser/hsm-dummy-pulser.cabal b/hsm-drive/hsm-drive.cabal index 747f62c..a9dbe69 100644 --- a/hsm-dummy-pulser/hsm-dummy-pulser.cabal +++ b/hsm-drive/hsm-drive.cabal @@ -2,24 +2,18 @@ cabal-version: 3.4 author: Paul Oliver build-type: Simple maintainer: contact@pauloliver.dev -name: hsm-dummy-pulser +name: hsm-drive version: 0.1.0.0 -executable dummy-pulser +library build-depends: , base , echo - , effectful - , hsm-core - , log-effectful - , resourcet-effectful - , streamly-core + , hsm-gpio + , hsm-log + , hsm-pwm , text - main-is: Main.hs + exposed-modules: Hsm.Drive 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-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-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..dd69122 100644 --- a/hsm-gpio/Hsm/GPIO.hs +++ b/hsm-gpio/Hsm/GPIO.hs @@ -1,120 +1,163 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} module Hsm.GPIO - ( GPIO(..) - , GPIOEffect - , toggle - , runGPIO + ( G.active + , G.inactive + , G.LineRequest + , GPIO(..) + , setPins + , setAllPins + , allocateGPIO ) where -import Data.Aeson (FromJSON) -import Data.Kind (Type) -import Data.List (intercalate) -import Data.Set (Set, toList, unions) -import Data.String (IsString) +import Control.IO.Region (Region, alloc, alloc_, defer, free) +import Control.Monad (forM_, void) +import Data.ByteString (useAsCString) 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 Data.Text.Encoding (encodeUtf8) +import Data.Vector.Storable qualified as V +import Foreign.C.Types (CSize(CSize), CUInt(CUInt)) +import Foreign.Ptr (Ptr) +import Hsm.GPIO.Lib qualified as G +import Hsm.Log qualified as L + +logMsg :: Text -> IO () +logMsg = L.logMsg ["gpio"] --- Monofunctional GPIO pins data GPIO - = GPIO5 + = GPIO2 + | GPIO3 + | GPIO4 + | GPIO5 | GPIO6 + | GPIO7 + | GPIO8 + | GPIO9 + | GPIO10 + | GPIO11 + | GPIO12 + | GPIO13 + | GPIO14 + | GPIO15 | GPIO16 | GPIO17 + -- | GPIO18 -- reserved for PWM + -- | GPIO19 -- reserved for PWM + | GPIO20 + | GPIO21 | GPIO22 | GPIO23 | GPIO24 | GPIO25 | GPIO26 | GPIO27 - deriving (Eq, FromJSON, Generic, Ord, Read, Show) - -data GPIOEffect key a b - -type instance DispatchOf (GPIOEffect key) = Static E.WithSideEffects + deriving (Bounded, Enum, Show) --- 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) +pinLine :: GPIO -> CUInt +pinLine = CUInt . read . drop 4 . show -domain :: Text -domain = "gpio" +allPins :: [GPIO] +allPins = [minBound .. maxBound] -stateStr :: IsString a => Bool -> a -stateStr True = "on" -stateStr False = "off" - --- 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) +allLines :: [CUInt] +allLines = pinLine <$> allPins -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) +setPins :: Ptr G.LineRequest -> [GPIO] -> G.LineValue -> IO () +setPins lineRequest pins lineValue = do + logMsg + $ "Setting pin(s) " + <> pack (show pins) <> " to state " - <> pack (show state) - <> " using periods " - <> pack (show periods) + <> pack (show lineValue) + forM_ pins $ \pin -> G.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 :: Ptr G.LineRequest -> G.LineValue -> IO () +setAllPins lineRequest lineValue = do + logMsg + $ "Setting all pins " + <> pack (show allPins) + <> " to state " + <> pack (show lineValue) + void + $ V.unsafeWith (V.replicate (length allPins) lineValue) + $ G.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 +allocateGPIO :: Region -> Text -> IO (Ptr G.LineRequest) +allocateGPIO region consumer = do + (chip, chipKey) <- allocateChip + (lineSettings, lineSettingsKey) <- allocateLineSettings + (lineConfig, lineConfigKey) <- allocateLineConfig lineSettings + (requestConfig, requestConfigKey) <- allocateRequestConfig + lineRequest <- allocateLineRequest chip requestConfig lineConfig + free requestConfigKey + free lineConfigKey + free lineSettingsKey + free chipKey + defer region $ setAllPins lineRequest G.inactive + return lineRequest 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" + -- GPIO chip + chipOpen = do + logMsg $ "Opening GPIO chip " <> chipPath + useAsCString (encodeUtf8 chipPath) G.chipOpen + chipClose chip = do + logMsg $ "Closing GPIO chip " <> chipPath + G.chipClose chip + allocateChip = alloc region chipOpen chipClose + -- Line settings + lineSettingsNew = do + logMsg "Allocating line settings" + lineSettings <- G.lineSettingsNew + logMsg $ "With direction set to " <> pack (show G.output) + void $ G.lineSettingsSetDirection lineSettings G.output + logMsg $ "With output set to " <> pack (show G.inactive) + void $ G.lineSettingsSetOutputValue lineSettings G.inactive + return lineSettings + lineSettingsFree lineSettings = do + logMsg "Freeing line settings" + G.lineSettingsFree lineSettings + allocateLineSettings = alloc region lineSettingsNew lineSettingsFree + -- Line config + lineConfigNew lineSettings = do + logMsg "Allocating line config" + logMsg $ "With GPIO pins " <> pack (show allPins) + lineConfig <- G.lineConfigNew + void + $ V.unsafeWith (V.fromList allLines) + $ \pinsVector -> + G.lineConfigAddLineSettings + lineConfig + pinsVector + (CSize $ fromIntegral $ length allPins) + lineSettings + return lineConfig + lineConfigFree lineConfig = do + logMsg "Freeing line config" + G.lineConfigFree lineConfig + allocateLineConfig lineSettings = + alloc region (lineConfigNew lineSettings) lineConfigFree + -- Request config + requestConfigNew = do + logMsg "Allocating request config" + logMsg $ "With consumer " <> consumer + requestConfig <- G.requestConfigNew + useAsCString (encodeUtf8 consumer) + $ G.requestConfigSetConsumer requestConfig + return requestConfig + requestConfigFree requestConfig = do + logMsg "Freeing request config" + G.requestConfigFree requestConfig + allocateRequestConfig = alloc region requestConfigNew requestConfigFree + -- Line request + requestLines chip requestConfig lineConfig = do + logMsg "Allocating line request" + G.requestLines chip requestConfig lineConfig + lineRequestRelease lineRequest = do + logMsg "Releasing line request" + G.lineRequestRelease lineRequest + allocateLineRequest chip requestConfig lineConfig = + alloc_ + region + (requestLines chip requestConfig lineConfig) + lineRequestRelease diff --git a/hsm-gpio/Hsm/GPIO/Lib.hsc b/hsm-gpio/Hsm/GPIO/Lib.hsc new file mode 100644 index 0000000..6716f3a --- /dev/null +++ b/hsm-gpio/Hsm/GPIO/Lib.hsc @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- This module provides C bindings to the `gpiod` library for direct GPIO pin +-- control. It includes bindings only for the C functions that are currently +-- used. In the future, creating a complete set of bindings for the entire +-- `gpiod` library as an external package would be a valuable contribution to +-- Hackage. + +module Hsm.GPIO.Lib + ( chipOpen + , chipClose + , input + , output + , LineValue + , active + , inactive + , lineSettingsNew + , lineSettingsFree + , lineSettingsSetDirection + , lineSettingsSetOutputValue + , lineConfigNew + , lineConfigFree + , lineConfigAddLineSettings + , requestConfigNew + , requestConfigFree + , requestConfigSetConsumer + , requestLines + , LineRequest + , lineRequestRelease + , lineRequestSetValue + , lineRequestSetValues + ) where + +#include <gpiod.h> + +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 ccall unsafe "gpiod.h gpiod_chip_open" + chipOpen :: CString -> IO (Ptr Chip) + +foreign import ccall unsafe "gpiod.h gpiod_chip_close" + chipClose :: Ptr Chip -> IO () + +data LineSettings + +newtype LineDirection = + LineDirection CInt + deriving (Show) + +#{enum LineDirection, LineDirection + , input = GPIOD_LINE_DIRECTION_INPUT + , output = GPIOD_LINE_DIRECTION_OUTPUT +} + +newtype LineValue = + LineValue CInt + deriving (Show, Storable) + +#{enum LineValue, LineValue + , active = GPIOD_LINE_VALUE_ACTIVE + , inactive = GPIOD_LINE_VALUE_INACTIVE +} + +foreign import ccall unsafe "gpiod.h gpiod_line_settings_new" + lineSettingsNew :: IO (Ptr LineSettings) + +foreign import ccall unsafe "gpiod.h gpiod_line_settings_free" + lineSettingsFree :: Ptr LineSettings -> IO () + +foreign import ccall unsafe "gpiod.h gpiod_line_settings_set_direction" + lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt + +foreign import ccall unsafe "gpiod.h gpiod_line_settings_set_output_value" + lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt + +data LineConfig + +foreign import ccall unsafe "gpiod.h gpiod_line_config_new" + lineConfigNew :: IO (Ptr LineConfig) + +foreign import ccall unsafe "gpiod.h gpiod_line_config_free" + lineConfigFree :: Ptr LineConfig -> IO () + +foreign import ccall unsafe "gpiod.d gpiod_line_config_add_line_settings" + lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt + +data RequestConfig + +foreign import ccall unsafe "gpiod.h gpiod_request_config_new" + requestConfigNew :: IO (Ptr RequestConfig) + +foreign import ccall unsafe "gpiod.h gpiod_request_config_free" + requestConfigFree :: Ptr RequestConfig -> IO () + +foreign import ccall unsafe "gpiod.h gpiod_request_config_set_consumer" + requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO () + +data LineRequest + +foreign import ccall unsafe "gpiod.h gpiod_chip_request_lines" + requestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest) + +foreign import ccall unsafe "gpiod.h gpiod_line_request_release" + lineRequestRelease :: Ptr LineRequest -> IO () + +foreign import ccall unsafe "gpiod.h gpiod_line_request_set_value" + lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt + +foreign import ccall unsafe "gpiod.h gpiod_line_request_set_values" + lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt diff --git a/hsm-gpio/hsm-gpio.cabal b/hsm-gpio/hsm-gpio.cabal index 8ff3e13..786977a 100644 --- a/hsm-gpio/hsm-gpio.cabal +++ b/hsm-gpio/hsm-gpio.cabal @@ -7,15 +7,15 @@ version: 0.1.0.0 library build-depends: - , aeson , base - , containers - , effectful-core - , hsm-core - , log-effectful - , process + , bytestring + , hsm-log + , io-region , text + , vector exposed-modules: Hsm.GPIO + other-modules: Hsm.GPIO.Lib ghc-options: -Wall -Wunused-packages + extra-libraries: gpiod default-language: GHC2021 diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs new file mode 100644 index 0000000..0f388be --- /dev/null +++ b/hsm-log/Hsm/Log.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Hsm.Log + ( logMsg + ) where + +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Time.Clock (getCurrentTime) +import Data.Time.ISO8601 (formatISO8601Millis) + +logMsg :: [T.Text] -> T.Text -> IO () +logMsg domain msg = do + time <- T.pack . formatISO8601Millis <$> getCurrentTime + T.putStrLn $ T.unwords [time, "[" <> T.intercalate "/" domain <> "]", msg] diff --git a/hsm-log/hsm-log.cabal b/hsm-log/hsm-log.cabal new file mode 100644 index 0000000..65279db --- /dev/null +++ b/hsm-log/hsm-log.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-log +version: 0.1.0.0 + +library + build-depends: + , base + , iso8601-time + , text + , time + + exposed-modules: Hsm.Log + ghc-options: -Wall -Wunused-packages + default-language: GHC2021 diff --git a/hsm-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs new file mode 100644 index 0000000..6b2a882 --- /dev/null +++ b/hsm-pwm/Hsm/PWM.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Hsm.PWM + ( PWMHandle + , PWMChannel(PWM2, PWM3) + , setCycleDuration + , allocatePWM + ) where + +import Control.Concurrent (threadDelay) +import Control.IO.Region (Region, alloc_) +import Control.Monad.Loops (untilM_) +import Data.Text (Text, pack) +import Hsm.Log qualified as L +import System.FilePath ((</>)) +import System.Posix.Files (fileAccess) + +-- This data type defines a placeholder `PWMHandle` to ensure that PWM actions +-- occur only after the `allocatePWM` function has been called. The empty +-- handle acts as a flag to enforce the correct order of operations. +data PWMHandle = + PWMHandle + +-- This PWM controller assumes `dtoverlay=pwm-2chan` is set in +-- `/boot/config.txt`, enabling PWM on GPIO 18 (channel 2) and GPIO 19 +-- (channel 3) for the Pi 5. Alternative configurations with additional PWM +-- channels are possible. For more information, consult the following links: +-- +-- - Modifications to `config.txt`: +-- https://www.pi4j.com/blog/2024/20240423_pwm_rpi5/#modify-configtxt +-- +-- - SysFS PWM interface: +-- https://forums.raspberrypi.com/viewtopic.php?t=359251 +-- +-- - UDEV setup for non-root access: +-- https://forums.raspberrypi.com/viewtopic.php?t=316514 +data PWMChannel + = PWM2 + | PWM3 + deriving (Bounded, Enum, Show) + +logMsg :: Text -> IO () +logMsg = L.logMsg ["pwm"] + +chipPath :: FilePath +chipPath = "/sys/class/pwm/pwmchip0" + +channelIndex :: PWMChannel -> Int +channelIndex = read . drop 3 . show + +channelPaths :: PWMChannel -> (FilePath, FilePath, FilePath) +channelPaths channel = (enablePath, periodPath, dutyCyclePath) + where + channelPath = chipPath </> ("pwm" <> show (channelIndex channel)) + enablePath = channelPath </> "enable" + periodPath = channelPath </> "period" + dutyCyclePath = channelPath </> "duty_cycle" + +setEnable :: PWMChannel -> Bool -> IO () +setEnable channel enable = do + logMsg $ "Setting " <> pack enablePath <> " to " <> pack (show enable) + writeFile enablePath enableString + where + (enablePath, _, _) = channelPaths channel + enableString = show $ fromEnum enable + +setPeriod :: PWMChannel -> Int -> IO () +setPeriod channel period = do + logMsg $ "Setting " <> pack periodPath <> " to " <> pack (show period) + writeFile periodPath $ show period + where + (_, periodPath, _) = channelPaths channel + +setDutyCycle :: PWMChannel -> Int -> IO () +setDutyCycle channel dutyCycle = do + logMsg $ "Setting " <> pack dutyCyclePath <> " to " <> pack (show dutyCycle) + writeFile dutyCyclePath $ show dutyCycle + where + (_, _, dutyCyclePath) = channelPaths channel + +setCycleDuration :: PWMHandle -> PWMChannel -> Int -> IO () +setCycleDuration _ channel 0 = do + logMsg $ "Halting PWM signals on channel " <> pack (show channel) + setEnable channel False +setCycleDuration _ channel cycleDuration = do + logMsg + $ "Setting cycle duration on channel " + <> pack (show channel) + <> " to " + <> pack (show cycleDuration) + setEnable channel False + -- Sets the duty cycle to zero before updating the period. This prevents + -- `Invalid argument` errors, as the period must never be set to a value + -- smaller than the duty cycle. + setDutyCycle channel 0 + setPeriod channel cycleDuration + setDutyCycle channel $ cycleDuration `div` 2 + setEnable channel True + +allocatePWM :: Region -> (PWMChannel -> Int) -> IO PWMHandle +allocatePWM region mapper = alloc_ region acquire $ const release + where + exportPath = chipPath </> "export" + unexportPath = chipPath </> "unexport" + -- This function waits for a file at the given `path` to become writable + -- by the `pwm` user group. A UDEV rule ensures that files in + -- `/sys/class/pwm/pwmchip*` are made writable through a `chown` call. + -- However, because UDEV rules are applied asynchronously, there may be a + -- brief delay before the rule takes effect. This function blocks and + -- repeatedly checks the file's write permissions by calling `fileAccess`. + -- It continues checking until write access is confirmed. + waitWritable path = do + logMsg $ "Waiting for " <> pack path <> " to become writable" + untilM_ (threadDelay 1000) $ fileAccess path False True False + allChannels = [minBound .. maxBound] + -- Acquire PWM channels + acquireChannel channel = do + logMsg + $ "Exporting channel " + <> pack (show channel) + <> " on chip " + <> pack chipPath + writeFile exportPath $ show (channelIndex channel) + let (enablePath, periodPath, dutyCyclePath) = channelPaths channel + waitWritable enablePath + waitWritable periodPath + waitWritable dutyCyclePath + setCycleDuration PWMHandle channel $ mapper channel + acquire = do + waitWritable exportPath + waitWritable unexportPath + mapM_ acquireChannel allChannels + return PWMHandle + -- Release PWM channels + releaseChannel channel = do + setEnable channel False + logMsg + $ "Unexporting channel " + <> pack (show channel) + <> " on chip " + <> pack chipPath + writeFile unexportPath $ show (channelIndex channel) + release = mapM_ releaseChannel allChannels diff --git a/hsm-pwm/hsm-pwm.cabal b/hsm-pwm/hsm-pwm.cabal new file mode 100644 index 0000000..8a6c44d --- /dev/null +++ b/hsm-pwm/hsm-pwm.cabal @@ -0,0 +1,21 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-pwm +version: 0.1.0.0 + +library + build-depends: + , base + , filepath + , hsm-log + , io-region + , monad-loops + , text + , unix + + exposed-modules: Hsm.PWM + ghc-options: -Wall -Wunused-packages + extra-libraries: gpiod + default-language: GHC2021 diff --git a/hsm-readline/Hsm/Readline.hs b/hsm-readline/Hsm/Readline.hs new file mode 100644 index 0000000..8a0c232 --- /dev/null +++ b/hsm-readline/Hsm/Readline.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Hsm.Readline + ( readline + , allocateReadline + ) where + +import Control.IO.Region (Region, alloc_) +import Data.Text (Text, pack) +import Data.Typeable (Proxy(Proxy), Typeable, typeRep) +import Hsm.Log qualified as L +import System.Console.Haskeline qualified as H +import System.Console.Haskeline.IO qualified as H +import Text.Read (readEither) + +logMsg :: Text -> IO () +logMsg = L.logMsg ["readline"] + +readline :: + forall a. (Read a, Show a, Typeable a) + => H.InputState + -> IO (Maybe a) +readline handle = do + logMsg $ "Expecting value of type " <> pack (show $ typeRep $ Proxy @a) + valueMaybe <- queryInput + maybe (return Nothing) parseValueStr valueMaybe + where + queryInput = + H.queryInput handle + $ H.handleInterrupt (return Nothing) + $ H.withInterrupt + $ H.getInputLine "% " + parseValueStr valueStr = + case readEither @a valueStr of + Right commandValue -> do + logMsg $ "Parsed value " <> pack (show commandValue) + return $ Just commandValue + Left err -> do + logMsg $ pack err + readline handle + +allocateReadline :: Region -> IO H.InputState +allocateReadline region = alloc_ region initializeInput cancelInput + where + initializeInput = do + logMsg "Initializing input with default settings" + H.initializeInput H.defaultSettings + cancelInput handle = do + logMsg "Cancelling input" + H.cancelInput handle diff --git a/hsm-readline/hsm-readline.cabal b/hsm-readline/hsm-readline.cabal new file mode 100644 index 0000000..4532219 --- /dev/null +++ b/hsm-readline/hsm-readline.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-readline +version: 0.1.0.0 + +library + build-depends: + , base + , haskeline + , hsm-log + , io-region + , text + + exposed-modules: Hsm.Readline + ghc-options: -Wall -Wunused-packages + default-language: GHC2021 diff --git a/hsm-status/Hsm/Status.hs b/hsm-status/Hsm/Status.hs new file mode 100644 index 0000000..8154611 --- /dev/null +++ b/hsm-status/Hsm/Status.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hsm.Status + ( StatusEnv(..) + , statusEnvDefault + , status + ) where + +import Foreign.Ptr (Ptr) +import GHC.Records (HasField) +import Hsm.GPIO (GPIO(..), LineRequest, active, inactive, setPins) +import Hsm.Log qualified as L + +data StatusEnv = StatusEnv + { gpioOk :: GPIO + , gpioError :: GPIO + } + +statusEnvDefault :: StatusEnv +statusEnvDefault = StatusEnv {gpioOk = GPIO17, gpioError = GPIO27} + +status :: + HasField "statusEnv" env StatusEnv + => Ptr LineRequest + -> env + -> [Bool] + -> IO () +status lineRequest env signals = do + if and signals + then do + logMsg "All signals OK" + setPins lineRequest [env.statusEnv.gpioError] inactive + setPins lineRequest [env.statusEnv.gpioOk] active + else do + logMsg "Error signal received" + setPins lineRequest [env.statusEnv.gpioError] active + setPins lineRequest [env.statusEnv.gpioOk] inactive + where + logMsg = L.logMsg ["status"] 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 index 64528bd..66560e8 100644 --- a/hsm-status/hsm-status.cabal +++ b/hsm-status/hsm-status.cabal @@ -8,32 +8,9 @@ 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 + , hsm-log - main-is: Main.hs - other-modules: Hsm.Status.Error + exposed-modules: Hsm.Status ghc-options: -Wall -Wunused-packages - - if !arch(x86_64) - ghc-options: -optl=-mno-fix-cortex-a53-835769 - default-language: GHC2021 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,10 @@ -allow-newer: true -extra-deps: - - log-effectful-1.0.1.0 - - resourcet-effectful-1.0.1.0 packages: - - hsm-command - - hsm-core - - hsm-dummy-blinker - - hsm-dummy-fail - - hsm-dummy-poller - - hsm-dummy-pulser - - hsm-dummy-receiver + - hsm-bin + - hsm-cam + - hsm-drive - hsm-gpio + - hsm-log + - hsm-pwm + - hsm-readline - hsm-status -snapshot: lts-23.3 +snapshot: lts-23.7 diff --git a/stack.yaml.lock b/stack.yaml.lock index aa298d4..6ce598a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,24 +3,10 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/topics/lock_files -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 +packages: [] snapshots: - completed: - sha256: dd89d2322cb5af74c6ab9d96c0c5f6c8e6653e0c991d619b4bb141a49cb98668 - size: 679282 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/3.yaml - original: lts-23.3 + sha256: 4ef79c30b9efcf07335cb3de532983a7ac4c5a4180bc17f6212a86b09ce2ff75 + size: 680777 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/7.yaml + original: lts-23.7 diff --git a/sysconf/97-libcamera.rules b/sysconf/97-libcamera.rules new file mode 100644 index 0000000..d92e2b4 --- /dev/null +++ b/sysconf/97-libcamera.rules @@ -0,0 +1,5 @@ +# This rule grants the `video` group access to GPIO the `dma_heap` subsystem. +# This facilitates video streaming using the Raspberry Pi camera module. +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..01a05ed --- /dev/null +++ b/sysconf/98-gpiod.rules @@ -0,0 +1,2 @@ +# This rule grants the `gpio` group access to GPIO devices. +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..8407ebe --- /dev/null +++ b/sysconf/99-pwm.rules @@ -0,0 +1,12 @@ +# This UDEV rule provides the `pwm` user group with access to PWM devices. +# Note that UDEV operates asynchronously, so there may be a slight delay +# between changes to the directory structure (e.g., when a new PWM channel is +# added) and the corresponding permission updates. To ensure the rule has been +# fully applied, you can use the command `udevadm settle` to wait for the UDEV +# process to complete. +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 |