diff options
Diffstat (limited to 'hsm-gpio')
| -rw-r--r-- | hsm-gpio/Hsm/GPIO.hs | 233 | ||||
| -rw-r--r-- | hsm-gpio/Hsm/GPIO/Lib.hsc | 116 | ||||
| -rw-r--r-- | hsm-gpio/hsm-gpio.cabal | 12 |
3 files changed, 260 insertions, 101 deletions
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs index bc08ef5..dd69122 100644 --- a/hsm-gpio/Hsm/GPIO.hs +++ b/hsm-gpio/Hsm/GPIO.hs @@ -1,120 +1,163 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} module Hsm.GPIO - ( GPIO(..) - , GPIOEffect - , toggle - , runGPIO + ( G.active + , G.inactive + , G.LineRequest + , GPIO(..) + , setPins + , setAllPins + , allocateGPIO ) where -import Data.Aeson (FromJSON) -import Data.Kind (Type) -import Data.List (intercalate) -import Data.Set (Set, toList, unions) -import Data.String (IsString) +import Control.IO.Region (Region, alloc, alloc_, defer, free) +import Control.Monad (forM_, void) +import Data.ByteString (useAsCString) 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 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"] --- Monofunctional GPIO pins data GPIO - = GPIO5 + = 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 (Eq, FromJSON, Generic, Ord, Read, Show) - -data GPIOEffect key a b - -type instance DispatchOf (GPIOEffect key) = Static E.WithSideEffects + deriving (Bounded, Enum, Show) --- 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) +pinLine :: GPIO -> CUInt +pinLine = CUInt . read . drop 4 . show -domain :: Text -domain = "gpio" +allPins :: [GPIO] +allPins = [minBound .. maxBound] -stateStr :: IsString a => Bool -> a -stateStr True = "on" -stateStr False = "off" - --- 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) +allLines :: [CUInt] +allLines = pinLine <$> allPins -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) +setPins :: Ptr G.LineRequest -> [GPIO] -> G.LineValue -> IO () +setPins lineRequest pins lineValue = do + logMsg + $ "Setting pin(s) " + <> pack (show pins) <> " to state " - <> pack (show state) - <> " using periods " - <> pack (show periods) + <> pack (show lineValue) + forM_ pins $ \pin -> G.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 :: 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 -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 +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 - 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" + -- 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 index 8ff3e13..786977a 100644 --- a/hsm-gpio/hsm-gpio.cabal +++ b/hsm-gpio/hsm-gpio.cabal @@ -7,15 +7,15 @@ version: 0.1.0.0 library build-depends: - , aeson , base - , containers - , effectful-core - , hsm-core - , log-effectful - , process + , 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 |