Adds C bindings to interface with libgpiod

3 files changed, 277 insertions, 69 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
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..92f1ab2 100644
--- a/hsm-gpio/hsm-gpio.cabal
+++ b/hsm-gpio/hsm-gpio.cabal
@@ -9,13 +9,17 @@ library
   build-depends:
     , aeson
     , base
+    , bytestring
     , containers
     , effectful-core
     , hsm-core
     , log-effectful
-    , process
+    , resourcet-effectful
     , text
+    , vector
 
   exposed-modules:  Hsm.GPIO
+  other-modules:    Hsm.GPIO.Lib
   ghc-options:      -Wall -Wunused-packages
+  extra-libraries:  gpiod
   default-language: GHC2021