1 files changed, 131 insertions, 0 deletions
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]