Adds GPIO effect and dummy blinker service

10 files changed, 273 insertions, 10 deletions

diff --git a/README.md b/README.md
index dd065da..c1bbe25 100644
--- a/README.md
+++ b/README.md
@@ -14,7 +14,7 @@ to build pipelines modularly and stream data within pipeline elements. E.g.
 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.)
+system dependencies on your host first (e.g. `libzmq`, `libgpiod`, etc.)
 
 ## Test
 On one terminal, run `stack exec dummy-receiver`. This will initialize a ZMQ
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
diff --git a/stack.yaml b/stack.yaml
index aff8282..bdfd598 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -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