diff options
Diffstat (limited to 'hsm-gpio')
| -rw-r--r-- | hsm-gpio/Hsm/GPIO.hs | 217 | ||||
| -rw-r--r-- | hsm-gpio/Hsm/GPIO/FFI.hsc | 116 | ||||
| -rw-r--r-- | hsm-gpio/hsm-gpio.cabal | 23 |
3 files changed, 241 insertions, 115 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 diff --git a/hsm-gpio/hsm-gpio.cabal b/hsm-gpio/hsm-gpio.cabal index 8ff3e13..ba538db 100644 --- a/hsm-gpio/hsm-gpio.cabal +++ b/hsm-gpio/hsm-gpio.cabal @@ -1,21 +1,22 @@ -cabal-version: 3.4 -author: Paul Oliver -build-type: Simple -maintainer: contact@pauloliver.dev +cabal-version: 3.8 +author: Paul Oliver <contact@pauloliver.dev> name: hsm-gpio version: 0.1.0.0 library build-depends: - , aeson , base - , containers , effectful-core + , effectful-plugin , hsm-core - , log-effectful - , process - , text + , hsm-log + , transformers + , vector + default-language: GHC2024 exposed-modules: Hsm.GPIO - ghc-options: -Wall -Wunused-packages - default-language: GHC2021 + ghc-options: + -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages + -ddump-splices -fplugin=Effectful.Plugin + + other-modules: Hsm.GPIO.FFI |