aboutsummaryrefslogtreecommitdiff
path: root/hsm-gpio
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-gpio')
-rw-r--r--hsm-gpio/Hsm/GPIO.hs163
-rw-r--r--hsm-gpio/Hsm/GPIO/Lib.hsc116
-rw-r--r--hsm-gpio/hsm-gpio.cabal21
3 files changed, 300 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
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
new file mode 100644
index 0000000..786977a
--- /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:
+ , base
+ , bytestring
+ , hsm-log
+ , io-region
+ , text
+ , vector
+
+ exposed-modules: Hsm.GPIO
+ other-modules: Hsm.GPIO.Lib
+ ghc-options: -Wall -Wunused-packages
+ extra-libraries: gpiod
+ default-language: GHC2021
powered by cgit v1.2.1, back to main portfolio site