diff options
| -rw-r--r-- | hsm-command/Hsm/Command/Readline.hs | 6 | ||||
| -rw-r--r-- | hsm-command/hsm-command.cabal | 1 | ||||
| -rw-r--r-- | hsm-core/Hsm/Core/Log.hs | 15 | ||||
| -rw-r--r-- | hsm-dummy-blinker/Main.hs | 71 | ||||
| -rw-r--r-- | hsm-dummy-blinker/hsm-dummy-blinker.cabal | 27 | ||||
| -rw-r--r-- | hsm-gpio/Hsm/GPIO.hs | 131 | ||||
| -rw-r--r-- | hsm-gpio/hsm-gpio.cabal | 21 | ||||
| -rw-r--r-- | servconf.yaml | 7 | ||||
| -rw-r--r-- | stack.yaml | 2 |
9 files changed, 272 insertions, 9 deletions
diff --git a/hsm-command/Hsm/Command/Readline.hs b/hsm-command/Hsm/Command/Readline.hs index 3c56453..428ed50 100644 --- a/hsm-command/Hsm/Command/Readline.hs +++ b/hsm-command/Hsm/Command/Readline.hs @@ -9,8 +9,9 @@ module Hsm.Command.Readline import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>)) import Effectful.Dispatch.Static qualified as S -import Effectful.Log (Log, getLoggerEnv, leLogger, waitForLogger) +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 @@ -29,9 +30,6 @@ readline = do Readline hdl <- S.getStaticRep S.unsafeEff_ $ nextLine hdl where - flushLogger :: Eff es () - flushLogger = getLoggerEnv >>= S.unsafeEff_ . waitForLogger . leLogger - -- nextLine :: H.InputState -> IO (Maybe String) nextLine hdl = H.queryInput hdl diff --git a/hsm-command/hsm-command.cabal b/hsm-command/hsm-command.cabal index 766f372..836bf07 100644 --- a/hsm-command/hsm-command.cabal +++ b/hsm-command/hsm-command.cabal @@ -11,6 +11,7 @@ library , binary , effectful-core , haskeline + , hsm-core , log-effectful , resourcet-effectful , streamly-core diff --git a/hsm-core/Hsm/Core/Log.hs b/hsm-core/Hsm/Core/Log.hs index 9bf8b37..6930e90 100644 --- a/hsm-core/Hsm/Core/Log.hs +++ b/hsm-core/Hsm/Core/Log.hs @@ -1,22 +1,27 @@ 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.Log (Log, LogLevel, getLoggerIO, logMessage) +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 :: Log :> es => Eff es (LogLevel -> Text -> IO ()) +withLogIO :: L.Log :> es => Eff es (L.LogLevel -> Text -> IO ()) withLogIO = do - logIO <- getLoggerIO + logIO <- L.getLoggerIO return $ \level message -> do now <- getCurrentTime logIO now level message emptyObject -logTup :: Log :> es => (LogLevel, Text) -> Eff es () -logTup (level, message) = logMessage 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-dummy-blinker/Main.hs b/hsm-dummy-blinker/Main.hs new file mode 100644 index 0000000..cfc6654 --- /dev/null +++ b/hsm-dummy-blinker/Main.hs @@ -0,0 +1,71 @@ +{-# 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" action + where + action :: () -> Env -> Bool -> F.FsmOutput () Bool Env Bool + action _ _ sta = + F.FsmOutput + (Just $ F.FsmResult sta False stateOff) + [(LogInfo, "Turning on blinker")] + +stateOff :: F.FsmState () Bool Env Bool +stateOff = F.FsmState "off" action + where + action :: () -> Env -> Bool -> F.FsmOutput () Bool Env Bool + action _ _ sta = + F.FsmOutput + (Just $ F.FsmResult sta True stateOn) + [(LogInfo, "Turning off blinker")] + +handle :: + forall es. (GPIOEffect () :> es, Log :> es, Reader Env :> es) + => S.Stream (Eff es) Bool + -> Eff es () +handle = S.fold S.drain . S.mapM handler + where + handler :: Bool -> Eff es () + 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 new file mode 100644 index 0000000..670252e --- /dev/null +++ b/hsm-dummy-blinker/hsm-dummy-blinker.cabal @@ -0,0 +1,27 @@ +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-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs new file mode 100644 index 0000000..e3deabd --- /dev/null +++ b/hsm-gpio/Hsm/GPIO.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Hsm.GPIO + ( GPIO(..) + , GPIOEffect + , toggle + , runGPIO + ) 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) + +-- Monofunctional GPIO pins +data GPIO + = GPIO5 + | GPIO6 + | GPIO16 + | GPIO17 + | 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 + +-- 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) + +domain :: Text +domain = "gpio" + +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 + command :: String + command = + "gpioset -t" + <> intercalate "," (show <$> periods) + <> " " + <> concatMap lineArg (toList gpios) + -- + lineArg :: GPIO -> String + lineArg gpio = show gpio <> "=" <> stateStr state <> " " + +getGPIOs :: GPIOEffect key :> es => key -> Eff es (Set GPIO) +getGPIOs key = do + GPIOEffect mapper <- E.getStaticRep + return $ mapper key + +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 :: Text + report = + "Setting pins " + <> pack (show gpios) + <> " mapped to key " + <> pack (show key) + <> " to state " + <> pack (show state) + <> " using periods " + <> pack (show periods) + +toggle :: + (GPIOEffect key :> es, Log :> es, Show key) + => Bool + -> key + -> [Int] + -> Eff es () +toggle state key periods = do + gpios <- getGPIOs key + logReport state key periods gpios + gpioset state gpios periods + +runGPIO :: + forall key es a. (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 releaser + where + gpios :: Set GPIO + gpios = unions $ mapper <$> [minBound .. maxBound] + -- + endReport :: Text + endReport = + "Setting all mapped pins " + <> pack (show gpios) + <> " to state " + <> stateStr False + -- + releaser :: Eff (GPIOEffect key : es) () + releaser = do + localDomain domain $ logTrace_ endReport + gpioset False gpios [0] diff --git a/hsm-gpio/hsm-gpio.cabal b/hsm-gpio/hsm-gpio.cabal new file mode 100644 index 0000000..8ff3e13 --- /dev/null +++ b/hsm-gpio/hsm-gpio.cabal @@ -0,0 +1,21 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-gpio +version: 0.1.0.0 + +library + build-depends: + , aeson + , base + , containers + , effectful-core + , hsm-core + , log-effectful + , process + , text + + exposed-modules: Hsm.GPIO + ghc-options: -Wall -Wunused-packages + default-language: GHC2021 diff --git a/servconf.yaml b/servconf.yaml index 9bf4c63..0eb74e7 100644 --- a/servconf.yaml +++ b/servconf.yaml @@ -1,6 +1,13 @@ command: name: command pubEp: tcp://0.0.0.0:10000 +dummy-blinker: + gpio: + - GPIO17 + - GPIO22 + - GPIO27 + name: blinker + period: 1000 dummy-poller: name: poller period: 3000000 @@ -5,7 +5,9 @@ extra-deps: packages: - hsm-command - hsm-core + - hsm-dummy-blinker - hsm-dummy-poller - hsm-dummy-pulser - hsm-dummy-receiver + - hsm-gpio snapshot: lts-23.3 |