InitialHEADmaster

1 files changed, 163 insertions, 0 deletions

diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
new file mode 100644
index 0000000..dd69122
--- /dev/null
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.GPIO
+  ( G.active
+  , G.inactive
+  , G.LineRequest
+  , GPIO(..)
+  , setPins
+  , setAllPins
+  , allocateGPIO
+  ) where
+
+import Control.IO.Region (Region, alloc, alloc_, defer, free)
+import Control.Monad (forM_, void)
+import Data.ByteString (useAsCString)
+import Data.Text (Text, pack)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Vector.Storable qualified as V
+import Foreign.C.Types (CSize(CSize), CUInt(CUInt))
+import Foreign.Ptr (Ptr)
+import Hsm.GPIO.Lib qualified as G
+import Hsm.Log qualified as L
+
+logMsg :: Text -> IO ()
+logMsg = L.logMsg ["gpio"]
+
+data GPIO
+  = GPIO2
+  | GPIO3
+  | GPIO4
+  | GPIO5
+  | GPIO6
+  | GPIO7
+  | GPIO8
+  | GPIO9
+  | GPIO10
+  | GPIO11
+  | GPIO12
+  | GPIO13
+  | GPIO14
+  | GPIO15
+  | GPIO16
+  | GPIO17
+  -- | GPIO18 -- reserved for PWM
+  -- | GPIO19 -- reserved for PWM
+  | GPIO20
+  | GPIO21
+  | GPIO22
+  | GPIO23
+  | GPIO24
+  | GPIO25
+  | GPIO26
+  | GPIO27
+  deriving (Bounded, Enum, Show)
+
+pinLine :: GPIO -> CUInt
+pinLine = CUInt . read . drop 4 . show
+
+allPins :: [GPIO]
+allPins = [minBound .. maxBound]
+
+allLines :: [CUInt]
+allLines = pinLine <$> allPins
+
+setPins :: Ptr G.LineRequest -> [GPIO] -> G.LineValue -> IO ()
+setPins lineRequest pins lineValue = do
+  logMsg
+    $ "Setting pin(s) "
+        <> pack (show pins)
+        <> " to state "
+        <> pack (show lineValue)
+  forM_ pins $ \pin -> G.lineRequestSetValue lineRequest (pinLine pin) lineValue
+
+setAllPins :: Ptr G.LineRequest -> G.LineValue -> IO ()
+setAllPins lineRequest lineValue = do
+  logMsg
+    $ "Setting all pins "
+        <> pack (show allPins)
+        <> " to state "
+        <> pack (show lineValue)
+  void
+    $ V.unsafeWith (V.replicate (length allPins) lineValue)
+    $ G.lineRequestSetValues lineRequest
+
+allocateGPIO :: Region -> Text -> IO (Ptr G.LineRequest)
+allocateGPIO region consumer = do
+  (chip, chipKey) <- allocateChip
+  (lineSettings, lineSettingsKey) <- allocateLineSettings
+  (lineConfig, lineConfigKey) <- allocateLineConfig lineSettings
+  (requestConfig, requestConfigKey) <- allocateRequestConfig
+  lineRequest <- allocateLineRequest chip requestConfig lineConfig
+  free requestConfigKey
+  free lineConfigKey
+  free lineSettingsKey
+  free chipKey
+  defer region $ setAllPins lineRequest G.inactive
+  return lineRequest
+  where
+    chipPath = "/dev/gpiochip0"
+    -- GPIO chip
+    chipOpen = do
+      logMsg $ "Opening GPIO chip " <> chipPath
+      useAsCString (encodeUtf8 chipPath) G.chipOpen
+    chipClose chip = do
+      logMsg $ "Closing GPIO chip " <> chipPath
+      G.chipClose chip
+    allocateChip = alloc region chipOpen chipClose
+    -- Line settings
+    lineSettingsNew = do
+      logMsg "Allocating line settings"
+      lineSettings <- G.lineSettingsNew
+      logMsg $ "With direction set to " <> pack (show G.output)
+      void $ G.lineSettingsSetDirection lineSettings G.output
+      logMsg $ "With output set to " <> pack (show G.inactive)
+      void $ G.lineSettingsSetOutputValue lineSettings G.inactive
+      return lineSettings
+    lineSettingsFree lineSettings = do
+      logMsg "Freeing line settings"
+      G.lineSettingsFree lineSettings
+    allocateLineSettings = alloc region lineSettingsNew lineSettingsFree
+    -- Line config
+    lineConfigNew lineSettings = do
+      logMsg "Allocating line config"
+      logMsg $ "With GPIO pins " <> pack (show allPins)
+      lineConfig <- G.lineConfigNew
+      void
+        $ V.unsafeWith (V.fromList allLines)
+        $ \pinsVector ->
+            G.lineConfigAddLineSettings
+              lineConfig
+              pinsVector
+              (CSize $ fromIntegral $ length allPins)
+              lineSettings
+      return lineConfig
+    lineConfigFree lineConfig = do
+      logMsg "Freeing line config"
+      G.lineConfigFree lineConfig
+    allocateLineConfig lineSettings =
+      alloc region (lineConfigNew lineSettings) lineConfigFree
+    -- Request config
+    requestConfigNew = do
+      logMsg "Allocating request config"
+      logMsg $ "With consumer " <> consumer
+      requestConfig <- G.requestConfigNew
+      useAsCString (encodeUtf8 consumer)
+        $ G.requestConfigSetConsumer requestConfig
+      return requestConfig
+    requestConfigFree requestConfig = do
+      logMsg "Freeing request config"
+      G.requestConfigFree requestConfig
+    allocateRequestConfig = alloc region requestConfigNew requestConfigFree
+    -- Line request
+    requestLines chip requestConfig lineConfig = do
+      logMsg "Allocating line request"
+      G.requestLines chip requestConfig lineConfig
+    lineRequestRelease lineRequest = do
+      logMsg "Releasing line request"
+      G.lineRequestRelease lineRequest
+    allocateLineRequest chip requestConfig lineConfig =
+      alloc_
+        region
+        (requestLines chip requestConfig lineConfig)
+        lineRequestRelease