diff options
Diffstat (limited to 'hsm-gpio/Hsm')
| -rw-r--r-- | hsm-gpio/Hsm/GPIO.hs | 135 | ||||
| -rw-r--r-- | hsm-gpio/Hsm/GPIO/FFI.hs | 95 | ||||
| -rw-r--r-- | hsm-gpio/Hsm/GPIO/FFI.hsc | 116 |
3 files changed, 177 insertions, 169 deletions
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs index 4786379..31b73d9 100644 --- a/hsm-gpio/Hsm/GPIO.hs +++ b/hsm-gpio/Hsm/GPIO.hs @@ -3,22 +3,24 @@ {-# LANGUAGE TypeFamilies #-} module Hsm.GPIO - ( GPIOPin(..) + ( GPIOPin (..) , GPIO , setPins , setAllPins , runGPIO - ) where + ) +where 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 (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>)) +import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_) import Effectful.Exception (bracket) -import Effectful.Resource (Resource, allocateEff, releaseEff) import Foreign.C.String (withCString) -import Foreign.C.Types (CSize(CSize), CUInt) +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 @@ -42,7 +44,7 @@ import Hsm.GPIO.FFI , requestConfigNew , requestConfigSetConsumer ) -import Hsm.Log (Log, Severity(Info, Trace), logMsg) +import Hsm.Log (Log, Severity (Info, Trace), logMsg) import Prelude hiding (replicate) $(makeSerial "GPIO" "Pin" "pinLine" ''CUInt $ [2 .. 17] <> [20 .. 27]) @@ -60,14 +62,14 @@ data GPIO (a :: * -> *) (b :: *) type instance DispatchOf GPIO = Static WithSideEffects -newtype instance StaticRep GPIO = - GPIO (Ptr LineRequest) +newtype instance StaticRep GPIO + = GPIO (Ptr LineRequest) 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 - forM_ pins $ \pin -> unsafeEff_ $ lineRequestSetValue lineRequest (pinLine pin) lineValue + unsafeEff_ . forM_ pins $ \pin -> lineRequestSetValue lineRequest (pinLine pin) lineValue setAllPins :: (GPIO :> es, Log "gpio" :> es) => LineValue -> Eff es () setAllPins lineValue = do @@ -75,68 +77,53 @@ setAllPins lineValue = do logMsg Trace $ "Setting all pins " <> show allPins <> " to " <> show lineValue unsafeEff_ . unsafeWith (replicate pinCount lineValue) $ void . lineRequestSetValues lineRequest -runGPIO :: (IOE :> es, Log "gpio" :> es, Resource :> es) => String -> Eff (GPIO : es) a -> Eff es a -runGPIO consumer action = do - (chipKey, chip) <- chipBracket - (lineSettingsKey, lineSettings) <- lineSettingsBracket - (lineConfigKey, lineConfig) <- lineConfigBracket lineSettings - (requestConfigKey, requestConfig) <- requestConfigBracket - lineRequestBracket chip requestConfig lineConfig $ \lineRequest -> do - releaseEff requestConfigKey - releaseEff lineConfigKey - releaseEff lineSettingsKey - releaseEff chipKey - evalStaticRep (GPIO lineRequest) action +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 - chipBracket = allocateEff chipAlloc chipDealloc - where - 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 - lineSettingsBracket = allocateEff lineSettingsAlloc lineSettingsDealloc - where - 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 - lineConfigBracket lineSettings = allocateEff lineConfigAlloc lineConfigDealloc - where - lineConfigAlloc = 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 - requestConfigBracket = allocateEff requestConfigAlloc requestConfigDealloc - where - 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 - lineRequestBracket chip requestConfig lineConfig = bracket lineRequestAlloc lineRequestDealloc - where - lineRequestAlloc = do - logMsg Info "Allocating line request" - liftIO $ chipRequestLines chip requestConfig lineConfig - lineRequestDealloc lineRequest = do - logMsg Info "Releasing line request" - liftIO $ lineRequestRelease lineRequest + 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.hs b/hsm-gpio/Hsm/GPIO/FFI.hs deleted file mode 100644 index e0d6d07..0000000 --- a/hsm-gpio/Hsm/GPIO/FFI.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# 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 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) - -foreign import capi unsafe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT" input :: LineDirection - -foreign import capi unsafe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT" output :: LineDirection - -newtype LineValue = - LineValue CInt - deriving (Show, Storable) - -foreign import capi unsafe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE" active :: LineValue - -foreign import capi unsafe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE" inactive :: LineValue - -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.h 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" chipRequestLines :: 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/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 |