Adds C bindings to interface with libgpiod

1 files changed, 156 insertions, 68 deletions

diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
index 3c5e8fc..0df5cdd 100644
--- a/hsm-gpio/Hsm/GPIO.hs
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -1,28 +1,42 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Hsm.GPIO
   ( GPIO(..)
   , GPIOEffect
-  , toggle
+  , G.LineValue
+  , G.active
+  , G.inactive
+  , setPins
+  , setAllPins
   , runGPIO
   ) where
 
+import Control.Monad (forM_, void)
 import Data.Aeson (FromJSON)
+import Data.ByteString (useAsCString)
 import Data.Kind (Type)
-import Data.List (intercalate)
-import Data.Set (Set, toList, unions)
+import Data.Set (Set, size, toList, unions)
 import Data.String (IsString)
 import Data.Text (Text, pack)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Vector.Storable qualified as V
 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 Effectful.Log (Log, LogLevel(LogTrace), localDomain, logTrace_)
+import Effectful.Reader.Static (Reader, ask)
+import Effectful.Resource (Resource, allocate, release)
+import Foreign.C.Types (CSize(CSize), CUInt(CUInt))
+import Foreign.Ptr (Ptr)
 import GHC.Generics (Generic)
-import Hsm.Core.Log (flushLogger)
-import System.Process (callCommand)
+import GHC.Records (HasField)
+import Hsm.Core.Log (flushLogger, withLogIO)
+import Hsm.GPIO.Lib qualified as G
 
 data GPIO
   = GPIO5
@@ -37,84 +51,158 @@ data GPIO
   | GPIO27
   deriving (Eq, FromJSON, Generic, Ord, Read, Show)
 
+gpiosMapped ::
+     forall key. (Bounded key, Enum key)
+  => (key -> Set GPIO)
+  -> Set GPIO
+gpiosMapped mapper = unions $ mapper <$> [minBound @key .. maxBound]
+
+gpioLine :: GPIO -> CUInt
+gpioLine = CUInt . read . drop 4 . show
+
 data GPIOEffect key a b
 
 type instance DispatchOf (GPIOEffect key) = Static E.WithSideEffects
 
--- The static representation of this effect is a function that maps a `key` to
--- a `Set` of GPIO pins. This allows a single `key` of any type to control
--- multiple pins simultaneously. By using a function (instead of `Data.Map`),
--- we ensure that the mapping is total, meaning every `key` will map to a
--- corresponding set of pins.
-newtype instance E.StaticRep (GPIOEffect (key :: Type)) =
-  GPIOEffect (key -> Set GPIO)
+-- The static representation of this effect contains a function that maps a
+-- `key` to a `Set` of GPIO pins. This allows a single `key` of any type to
+-- control multiple pins simultaneously. By using a function (instead of
+-- `Data.Map`), we ensure that the mapping is total, meaning every `key` will
+-- map to a corresponding set of pins.
+data instance E.StaticRep (GPIOEffect (key :: Type)) =
+  GPIOEffect (key -> Set GPIO) (Ptr G.LineRequest)
 
 domain :: Text
 domain = "gpio"
 
-stateStr :: IsString a => Bool -> a
-stateStr True = "on"
-stateStr False = "off"
-
--- Currently, pin control is done via a subprocess call to `gpioset`. In the
--- future, I'd prefer to wrap `libgpiod` directly. It seems no C wrapper
--- exists yet, but I might create one.
-gpioset :: Log :> es => Bool -> Set GPIO -> [Word] -> 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)
+chipPath :: IsString a => a
+chipPath = "/dev/gpiochip0"
 
-logReport ::
-     (Log :> es, Show key) => Bool -> key -> [Word] -> Set GPIO -> Eff es ()
-logReport state key periods gpios = do
-  localDomain domain $ logTrace_ report
-  flushLogger
-  where
-    report =
-      "Setting pins "
-        <> pack (show gpios)
-        <> " mapped to key "
-        <> pack (show key)
-        <> " to state "
-        <> pack (show state)
-        <> " using periods "
-        <> pack (show periods)
-
-toggle ::
+setPins ::
      (GPIOEffect key :> es, Log :> es, Show key)
-  => Bool
+  => G.LineValue
   -> key
-  -> [Word]
   -> Eff es ()
-toggle state key periods = do
-  GPIOEffect mapper <- E.getStaticRep
-  set $ mapper key
+setPins lineValue key = do
+  GPIOEffect mapper lineRequest <- E.getStaticRep
+  forM_ (mapper key) $ \pin -> do
+    localDomain domain
+      $ logTrace_
+      $ "Setting PIN "
+          <> pack (show pin)
+          <> " mapped to key "
+          <> pack (show key)
+          <> " to state "
+          <> pack (show lineValue)
+    flushLogger
+    E.unsafeEff_ $ G.lineRequestSetValue lineRequest (gpioLine pin) lineValue
+
+setAllPins ::
+     forall key es. (GPIOEffect key :> es, Log :> es, Bounded key, Enum key)
+  => G.LineValue
+  -> Eff es ()
+setAllPins lineValue = E.getStaticRep >>= setter
   where
-    set gpios = do
-      logReport state key periods gpios
-      gpioset state gpios periods
+    setter (GPIOEffect mapper lineRequest) = do
+      localDomain domain
+        $ logTrace_
+        $ "Setting all mapped PINs "
+            <> pack (show mapped)
+            <> " to state "
+            <> pack (show lineValue)
+      flushLogger
+      void
+        $ E.unsafeEff_
+        $ V.unsafeWith lineValuesVector
+        $ G.lineRequestSetValues lineRequest
+      where
+        mapped = gpiosMapped @key mapper
+        lineValuesVector = V.replicate (size mapped) lineValue
 
 runGPIO ::
-     (IOE :> es, Log :> es, Bounded key, Enum key)
+     forall env es key a.
+     ( HasField "name" env Text
+     , IOE :> es
+     , Log :> es
+     , Reader env :> es
+     , Resource :> es
+     , Bounded key
+     , Enum key
+     )
   => (key -> Set GPIO)
   -> Eff (GPIOEffect key : es) a
   -> Eff es a
-runGPIO mapper action =
-  E.evalStaticRep (GPIOEffect mapper) $ finally action release
+runGPIO mapper action = do
+  lineRequest <- localDomain domain $ withLogIO >>= bootstrap
+  E.evalStaticRep (GPIOEffect mapper lineRequest)
+    $ finally action
+    $ setAllPins @key G.inactive
   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]
+    bootstrap logIO = do
+      (chipKey, chip) <- allocate chipOpen chipClose
+      (lineSettingsKey, lineSettings) <-
+        allocate lineSettingsNew lineSettingsFree
+      (lineConfigKey, lineConfig) <-
+        allocate (lineConfigNew lineSettings) lineConfigFree
+      env <- ask @env
+      (requestConfigKey, requestConfig) <-
+        allocate (requestConfigNew env.name) requestConfigFree
+      (_, lineRequest) <-
+        allocate (requestLines chip requestConfig lineConfig) lineRequestRelease
+      release requestConfigKey
+      release lineConfigKey
+      release lineSettingsKey
+      release chipKey
+      return lineRequest
+      where
+        gpiosVector = V.fromList $ gpioLine <$> toList (gpiosMapped mapper)
+        gpiosSize = CSize $ fromIntegral $ V.length gpiosVector
+        chipOpen = do
+          logIO LogTrace $ "Opening GPIO chip " <> chipPath
+          useAsCString chipPath G.chipOpen
+        chipClose chip = do
+          logIO LogTrace $ "Closing GPIO chip " <> chipPath
+          G.chipClose chip
+        lineSettingsNew = do
+          logIO LogTrace "Allocating line settings"
+          lineSettings <- G.lineSettingsNew
+          logIO LogTrace $ "With direction set to " <> pack (show G.output)
+          void $ G.lineSettingsSetDirection lineSettings G.output
+          logIO LogTrace $ "With output set to " <> pack (show G.inactive)
+          void $ G.lineSettingsSetOutputValue lineSettings G.inactive
+          return lineSettings
+        lineSettingsFree lineSettings = do
+          logIO LogTrace "Freeing line settings"
+          G.lineSettingsFree lineSettings
+        lineConfigNew lineSettings = do
+          logIO LogTrace "Allocating line config"
+          logIO LogTrace $ "With GPIOs " <> pack (show gpiosVector)
+          lineConfig <- G.lineConfigNew
+          void
+            $ V.unsafeWith gpiosVector
+            $ \gpiosPtr ->
+                G.lineConfigAddLineSettings
+                  lineConfig
+                  gpiosPtr
+                  gpiosSize
+                  lineSettings
+          return lineConfig
+        lineConfigFree lineConfig = do
+          logIO LogTrace "Freeing line config"
+          G.lineConfigFree lineConfig
+        requestConfigNew consumer = do
+          logIO LogTrace "Allocating request config"
+          logIO LogTrace $ "With consumer " <> consumer
+          requestConfig <- G.requestConfigNew
+          useAsCString (encodeUtf8 consumer)
+            $ G.requestConfigSetConsumer requestConfig
+          return requestConfig
+        requestConfigFree requestConfig = do
+          logIO LogTrace "Freeing request config"
+          G.requestConfigFree requestConfig
+        requestLines chip requestConfig lineConfig = do
+          logIO LogTrace "Requesting lines from chip"
+          G.requestLines chip requestConfig lineConfig
+        lineRequestRelease lineRequest = do
+          logIO LogTrace "Releasing lines"
+          G.lineRequestRelease lineRequest