From e876094f54aa3d4fc57b0ee3455ba5653facce67 Mon Sep 17 00:00:00 2001 From: Paul Oliver Date: Mon, 27 Jan 2025 21:43:49 +0000 Subject: Adds C bindings to interface with libgpiod --- hsm-dummy-blinker/Main.hs | 30 ++-- hsm-dummy-blinker/hsm-dummy-blinker.cabal | 2 +- hsm-gpio/Hsm/GPIO.hs | 224 +++++++++++++++++++++--------- hsm-gpio/Hsm/GPIO/Lib.hsc | 116 ++++++++++++++++ hsm-gpio/hsm-gpio.cabal | 6 +- hsm-status/Main.hs | 21 +-- hsm-status/hsm-status.cabal | 2 +- servconf.yaml | 4 +- 8 files changed, 309 insertions(+), 96 deletions(-) create mode 100644 hsm-gpio/Hsm/GPIO/Lib.hsc diff --git a/hsm-dummy-blinker/Main.hs b/hsm-dummy-blinker/Main.hs index 5c7cb13..779bf6c 100644 --- a/hsm-dummy-blinker/Main.hs +++ b/hsm-dummy-blinker/Main.hs @@ -6,58 +6,60 @@ import Data.Function ((&)) import Data.Set (fromList) import Data.Text (Text) import Effectful (Eff, (:>), runEff) +import Effectful.Concurrent (Concurrent, runConcurrent, threadDelay) import Effectful.Log (Log, LogLevel(LogInfo), runLog) -import Effectful.Reader.Static (Reader, ask, runReader) +import Effectful.Reader.Static (Reader, asks, runReader) import Effectful.Resource (runResource) import Effectful.State.Static.Local (evalState) import Hsm.Core.App (launch) import Hsm.Core.Env (deriveFromYaml) import Hsm.Core.Fsm qualified as F -import Hsm.GPIO (GPIO, GPIOEffect, runGPIO, toggle) +import Hsm.GPIO qualified as G import Streamly.Data.Fold qualified as S (drain) import Streamly.Data.Stream qualified as S (Stream, fold, mapM, repeat) import System.IO.Echo (withoutInputEcho) data Env = Env { name :: Text - , gpio :: [GPIO] + , gpio :: [G.GPIO] , period :: Word } $(deriveFromYaml ''Env) -stateOn :: F.FsmState () Bool Env Bool +stateOn :: F.FsmState () G.LineValue Env G.LineValue stateOn = F.FsmState "on" $ \_ _ sta -> F.FsmOutput - (Just $ F.FsmResult sta False stateOff) + (Just $ F.FsmResult sta G.inactive stateOff) [(LogInfo, "Turning on blinker")] -stateOff :: F.FsmState () Bool Env Bool +stateOff :: F.FsmState () G.LineValue Env G.LineValue stateOff = F.FsmState "off" $ \_ _ sta -> F.FsmOutput - (Just $ F.FsmResult sta True stateOn) + (Just $ F.FsmResult sta G.active stateOn) [(LogInfo, "Turning off blinker")] handle :: - (GPIOEffect () :> es, Log :> es, Reader Env :> es) - => S.Stream (Eff es) Bool + (Concurrent :> es, G.GPIOEffect () :> es, Log :> es, Reader Env :> es) + => S.Stream (Eff es) G.LineValue -> Eff es () handle = S.fold S.drain . S.mapM handler where handler sta = do - env <- ask @Env - toggle sta () [env.period, 0] + G.setAllPins @() sta + asks period >>= threadDelay . fromIntegral -- Dummy Blinker Service: A proof of concept that toggles a GPIO pin on and -- off at a set interval. main :: IO () main = launch @Env "dummy-blinker" withoutInputEcho $ \env logger level -> - (S.repeat () & F.fsm @_ @_ @Env @Bool & handle) - & runGPIO (\() -> fromList env.gpio) - & evalState False + (S.repeat () & F.fsm @_ @_ @Env @G.LineValue & handle) + & G.runGPIO @Env (\() -> fromList env.gpio) + & runConcurrent + & evalState G.inactive & evalState stateOff & runLog env.name logger level & runReader env diff --git a/hsm-dummy-blinker/hsm-dummy-blinker.cabal b/hsm-dummy-blinker/hsm-dummy-blinker.cabal index 670252e..48561f4 100644 --- a/hsm-dummy-blinker/hsm-dummy-blinker.cabal +++ b/hsm-dummy-blinker/hsm-dummy-blinker.cabal @@ -10,7 +10,7 @@ executable dummy-blinker , base , containers , echo - , effectful-core + , effectful , hsm-core , hsm-gpio , log-effectful 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 + +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 diff --git a/hsm-status/Main.hs b/hsm-status/Main.hs index 594661b..8d02d76 100644 --- a/hsm-status/Main.hs +++ b/hsm-status/Main.hs @@ -7,8 +7,9 @@ import Data.Function ((&)) import Data.Set (Set, singleton) import Data.Text (Text, pack) import Effectful (Eff, (:>), runEff) +import Effectful.Concurrent (Concurrent, runConcurrent, threadDelay) import Effectful.Log (Log, LogLevel(LogAttention), runLog) -import Effectful.Reader.Static (Reader, ask, runReader) +import Effectful.Reader.Static (Reader, asks, runReader) import Effectful.Resource (runResource) import Effectful.State.Static.Local (evalState) import Hsm.Core.App (launch) @@ -16,7 +17,7 @@ import Hsm.Core.Env (deriveFromYaml) import Hsm.Core.Fsm qualified as F import Hsm.Core.Message (body) import Hsm.Core.Zmq.Client (poll, runClient) -import Hsm.GPIO (GPIO, GPIOEffect, runGPIO, toggle) +import Hsm.GPIO qualified as G import Hsm.Status.Error (Error(Error)) import Streamly.Data.Fold qualified as S (drain) import Streamly.Data.Stream qualified as S (Stream, fold, mapM) @@ -24,8 +25,8 @@ import System.IO.Echo (withoutInputEcho) data Env = Env { name :: Text - , gpioOk :: GPIO - , gpioError :: GPIO + , gpioOk :: G.GPIO + , gpioError :: G.GPIO , period :: Word , subEps :: [Text] , topics :: [Text] @@ -60,16 +61,17 @@ stateError :: F.FsmState [ByteString] Bool Env () stateError = F.FsmState "error" $ \errs _ _ -> result False stateError errs handle :: - (GPIOEffect Bool :> es, Log :> es, Reader Env :> es) + (Concurrent :> es, G.GPIOEffect Bool :> es, Log :> es, Reader Env :> es) => S.Stream (Eff es) Bool -> Eff es () handle = S.fold S.drain . S.mapM handler where + sleep = asks period >>= threadDelay . fromIntegral handler sta = do - env <- ask @Env - toggle False sta [env.period, env.period, 0] + G.setPins G.active sta >> sleep + G.setPins G.inactive sta >> sleep -mapper :: Env -> Bool -> Set GPIO +mapper :: Env -> Bool -> Set G.GPIO mapper env True = singleton env.gpioOk mapper env False = singleton env.gpioError @@ -80,7 +82,8 @@ main = launch "status" withoutInputEcho $ \env logger level -> (poll & F.fsm @_ @_ @Env @() & handle) & runClient @Env - & runGPIO (mapper env) + & G.runGPIO @Env (mapper env) + & runConcurrent & evalState () & evalState stateOk & runLog env.name logger level diff --git a/hsm-status/hsm-status.cabal b/hsm-status/hsm-status.cabal index feeff93..108ce45 100644 --- a/hsm-status/hsm-status.cabal +++ b/hsm-status/hsm-status.cabal @@ -22,7 +22,7 @@ executable status , bytestring , containers , echo - , effectful-core + , effectful , hsm-core , hsm-gpio , log-effectful diff --git a/servconf.yaml b/servconf.yaml index b2b01cd..0b25e88 100644 --- a/servconf.yaml +++ b/servconf.yaml @@ -7,7 +7,7 @@ dummy-blinker: - GPIO22 - GPIO27 name: blinker - period: 1000 + period: 1000000 dummy-fail: alive: 1000000 name: fail @@ -38,7 +38,7 @@ status: gpioError: GPIO17 gpioOk: GPIO22 name: status - period: 1000 + period: 1000000 subEps: - tcp://0.0.0.0:10002 topics: -- cgit v1.2.1