aboutsummaryrefslogtreecommitdiff
path: root/hsm-gpio/Hsm
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-gpio/Hsm')
-rw-r--r--hsm-gpio/Hsm/GPIO.hs217
-rw-r--r--hsm-gpio/Hsm/GPIO/FFI.hsc116
2 files changed, 229 insertions, 104 deletions
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
index bc08ef5..31b73d9 100644
--- a/hsm-gpio/Hsm/GPIO.hs
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -1,120 +1,129 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hsm.GPIO
- ( GPIO(..)
- , GPIOEffect
- , toggle
+ ( GPIOPin (..)
+ , GPIO
+ , setPins
+ , setAllPins
, runGPIO
- ) where
+ )
+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)
+import Control.Monad (forM_, void)
+import Control.Monad.Trans.Cont (evalCont)
+import Data.Vector.Storable (fromList, replicate, unsafeWith)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
+import Effectful.Exception (bracket)
+import Foreign.C.String (withCString)
+import Foreign.C.Types (CSize (CSize), CUInt)
+import Foreign.Ptr (Ptr)
+import Hsm.Core.Bracket (bracketCont)
+import Hsm.Core.Serial (makeSerial)
+import Hsm.GPIO.FFI
+ ( LineRequest
+ , LineValue
+ , chipClose
+ , chipOpen
+ , chipRequestLines
+ , inactive
+ , lineConfigAddLineSettings
+ , lineConfigFree
+ , lineConfigNew
+ , lineRequestRelease
+ , lineRequestSetValue
+ , lineRequestSetValues
+ , lineSettingsFree
+ , lineSettingsNew
+ , lineSettingsSetDirection
+ , lineSettingsSetOutputValue
+ , output
+ , requestConfigFree
+ , requestConfigNew
+ , requestConfigSetConsumer
+ )
+import Hsm.Log (Log, Severity (Info, Trace), logMsg)
+import Prelude hiding (replicate)
--- Monofunctional GPIO pins
-data GPIO
- = GPIO5
- | GPIO6
- | GPIO16
- | GPIO17
- | GPIO22
- | GPIO23
- | GPIO24
- | GPIO25
- | GPIO26
- | GPIO27
- deriving (Eq, FromJSON, Generic, Ord, Read, Show)
+$(makeSerial "GPIO" "Pin" "pinLine" ''CUInt $ [2 .. 17] <> [20 .. 27])
-data GPIOEffect key a b
+allPins :: [GPIOPin]
+allPins = [minBound .. maxBound]
-type instance DispatchOf (GPIOEffect key) = Static E.WithSideEffects
+allLines :: [CUInt]
+allLines = pinLine <$> allPins
--- 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)
+pinCount :: Int
+pinCount = length allPins
-domain :: Text
-domain = "gpio"
+data GPIO (a :: * -> *) (b :: *)
-stateStr :: IsString a => Bool -> a
-stateStr True = "on"
-stateStr False = "off"
+type instance DispatchOf GPIO = Static WithSideEffects
--- 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
- lineArg gpio = show gpio <> "=" <> stateStr state <> " "
- command =
- "gpioset -t"
- <> intercalate "," (show <$> periods)
- <> " "
- <> concatMap lineArg (toList gpios)
+newtype instance StaticRep GPIO
+ = GPIO (Ptr LineRequest)
-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 =
- "Setting pins "
- <> pack (show gpios)
- <> " mapped to key "
- <> pack (show key)
- <> " to state "
- <> pack (show state)
- <> " using periods "
- <> pack (show periods)
+setPins :: (GPIO :> es, Log "gpio" :> es) => [GPIOPin] -> LineValue -> Eff es ()
+setPins pins lineValue = do
+ GPIO lineRequest <- getStaticRep
+ logMsg Trace $ "Setting pin(s) " <> show pins <> " to " <> show lineValue
+ unsafeEff_ . forM_ pins $ \pin -> lineRequestSetValue lineRequest (pinLine pin) lineValue
-toggle ::
- (GPIOEffect key :> es, Log :> es, Show key)
- => Bool
- -> key
- -> [Int]
- -> Eff es ()
-toggle state key periods = do
- GPIOEffect mapper <- E.getStaticRep
- set $ mapper key
- where
- set gpios = do
- logReport state key periods gpios
- gpioset state gpios periods
+setAllPins :: (GPIO :> es, Log "gpio" :> es) => LineValue -> Eff es ()
+setAllPins lineValue = do
+ GPIO lineRequest <- getStaticRep
+ logMsg Trace $ "Setting all pins " <> show allPins <> " to " <> show lineValue
+ unsafeEff_ . unsafeWith (replicate pinCount lineValue) $ void . lineRequestSetValues lineRequest
-runGPIO ::
- (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 release
+runGPIO :: (IOE :> es, Log "gpio" :> es) => String -> Eff (GPIO : es) a -> Eff es a
+runGPIO consumer action = bracket lineRequestAlloc lineRequestDealloc $ \lineRequest -> evalStaticRep (GPIO lineRequest) action
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]
+ chipPath = "/dev/gpiochip0"
+ chipAlloc = do
+ logMsg Info $ "Opening GPIO chip " <> chipPath
+ liftIO $ withCString chipPath chipOpen
+ chipDealloc chip = do
+ logMsg Info $ "Closing GPIO chip " <> chipPath
+ liftIO $ chipClose chip
+ lineSettingsAlloc = do
+ logMsg Info "Allocating line settings"
+ lineSettings <- liftIO lineSettingsNew
+ logMsg Info $ "With direction set to " <> show output
+ liftIO . void $ lineSettingsSetDirection lineSettings output
+ logMsg Info $ "With output set to " <> show inactive
+ liftIO . void $ lineSettingsSetOutputValue lineSettings inactive
+ return lineSettings
+ lineSettingsDealloc lineSettings = do
+ logMsg Info "Freeing line settings"
+ liftIO $ lineSettingsFree lineSettings
+ lineConfigAlloc lineSettings = do
+ logMsg Info "Allocating line config"
+ logMsg Info $ "With GPIO pins " <> show allPins
+ lineConfig <- liftIO lineConfigNew
+ liftIO . void . unsafeWith (fromList allLines) $ \pinsVector -> lineConfigAddLineSettings lineConfig pinsVector (CSize $ fromIntegral pinCount) lineSettings
+ return lineConfig
+ lineConfigDealloc lineConfig = do
+ logMsg Info "Freeing line config"
+ liftIO $ lineConfigFree lineConfig
+ requestConfigAlloc = do
+ logMsg Info "Allocating request config"
+ logMsg Info $ "With consumer " <> consumer
+ requestConfig <- liftIO requestConfigNew
+ liftIO . withCString consumer $ requestConfigSetConsumer requestConfig
+ return requestConfig
+ requestConfigDealloc requestConfig = do
+ logMsg Info "Freeing request config"
+ liftIO $ requestConfigFree requestConfig
+ lineRequestAlloc = do
+ logMsg Info "Allocating line request"
+ evalCont $ do
+ chip <- bracketCont chipAlloc chipDealloc
+ lineSettings <- bracketCont lineSettingsAlloc lineSettingsDealloc
+ lineConfig <- bracketCont (lineConfigAlloc lineSettings) lineConfigDealloc
+ requestConfig <- bracketCont requestConfigAlloc requestConfigDealloc
+ return . liftIO $ chipRequestLines chip requestConfig lineConfig
+ lineRequestDealloc lineRequest = do
+ logMsg Info "Releasing line request"
+ liftIO $ lineRequestRelease lineRequest
diff --git a/hsm-gpio/Hsm/GPIO/FFI.hsc b/hsm-gpio/Hsm/GPIO/FFI.hsc
new file mode 100644
index 0000000..d8b0f47
--- /dev/null
+++ b/hsm-gpio/Hsm/GPIO/FFI.hsc
@@ -0,0 +1,116 @@
+{-# LANGUAGE CApiFFI #-}
+
+-- FFI bindings to `libgpiod` for direct GPIO hardware access.
+--
+-- Exposes only the minimal required subset of `libgpiod` functionality used by
+-- this project. The bindings are suitable for low-level hardware control.
+--
+-- Future work could expand this into a comprehensive `gpiod` binding package.
+module Hsm.GPIO.FFI
+ ( chipOpen
+ , chipClose
+ , input
+ , output
+ , LineValue
+ , active
+ , inactive
+ , lineSettingsNew
+ , lineSettingsFree
+ , lineSettingsSetDirection
+ , lineSettingsSetOutputValue
+ , lineConfigNew
+ , lineConfigFree
+ , lineConfigAddLineSettings
+ , requestConfigNew
+ , requestConfigFree
+ , requestConfigSetConsumer
+ , LineRequest
+ , chipRequestLines
+ , lineRequestRelease
+ , lineRequestSetValue
+ , lineRequestSetValues
+ )
+where
+
+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 capi safe "gpiod.h gpiod_chip_open"
+ chipOpen :: CString -> IO (Ptr Chip)
+
+foreign import capi safe "gpiod.h gpiod_chip_close"
+ chipClose :: Ptr Chip -> IO ()
+
+data LineSettings
+
+newtype LineDirection
+ = LineDirection CInt
+ deriving Show
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT"
+ input :: LineDirection
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT"
+ output :: LineDirection
+
+newtype LineValue
+ = LineValue CInt
+ deriving (Show, Storable)
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE"
+ active :: LineValue
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE"
+ inactive :: LineValue
+
+foreign import capi safe "gpiod.h gpiod_line_settings_new"
+ lineSettingsNew :: IO (Ptr LineSettings)
+
+foreign import capi safe "gpiod.h gpiod_line_settings_free"
+ lineSettingsFree :: Ptr LineSettings -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_settings_set_direction"
+ lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
+
+foreign import capi safe "gpiod.h gpiod_line_settings_set_output_value"
+ lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
+
+data LineConfig
+
+foreign import capi safe "gpiod.h gpiod_line_config_new"
+ lineConfigNew :: IO (Ptr LineConfig)
+
+foreign import capi safe "gpiod.h gpiod_line_config_free"
+ lineConfigFree :: Ptr LineConfig -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_config_add_line_settings"
+ lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
+
+data RequestConfig
+
+foreign import capi safe "gpiod.h gpiod_request_config_new"
+ requestConfigNew :: IO (Ptr RequestConfig)
+
+foreign import capi safe "gpiod.h gpiod_request_config_free"
+ requestConfigFree :: Ptr RequestConfig -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_request_config_set_consumer"
+ requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
+
+data LineRequest
+
+foreign import capi safe "gpiod.h gpiod_chip_request_lines"
+ chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
+
+foreign import capi safe "gpiod.h gpiod_line_request_release"
+ lineRequestRelease :: Ptr LineRequest -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_request_set_value"
+ lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
+
+foreign import capi safe "gpiod.h gpiod_line_request_set_values"
+ lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
powered by cgit v1.2.1, back to main portfolio site