diff options
| -rw-r--r-- | hsm-pwm/Hsm/PWM.hs | 58 | ||||
| -rw-r--r-- | hsm-pwm/hsm-pwm.cabal | 5 |
2 files changed, 45 insertions, 18 deletions
diff --git a/hsm-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs index c7bb1e5..afc13c4 100644 --- a/hsm-pwm/Hsm/PWM.hs +++ b/hsm-pwm/Hsm/PWM.hs @@ -11,15 +11,17 @@ module Hsm.PWM , runPWM ) where +import Control.Monad.Loops (untilM_) import Data.Text (Text, pack) import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>)) +import Effectful.Concurrent (Concurrent, threadDelay) import Effectful.Dispatch.Static qualified as E import Effectful.Exception (bracket_) import Effectful.Log (Log, localDomain, logTrace_) import Effectful.Reader.Static (Reader, ask) import GHC.Records (HasField) import System.FilePath ((</>)) -import System.Process (callCommand) +import System.Posix.Files (fileAccess) -- This `PWMEffect` implementation assumes `dtoverlay=pwm` is set in -- `/boot/config.txt`, enabling PWM on GPIO 18 (channel 2) for the Pi 5. The @@ -47,6 +49,12 @@ domain = "pwm" pwmchip :: FilePath pwmchip = "/sys/class/pwm/pwmchip0" +exportPath :: FilePath +exportPath = pwmchip </> "export" + +unexportPath :: FilePath +unexportPath = pwmchip </> "unexport" + chanIdx :: Word chanIdx = 2 @@ -56,14 +64,30 @@ chanPath = pwmchip </> ("pwm" <> show chanIdx) enablePath :: FilePath enablePath = chanPath </> "enable" -dutyCycle :: (Log :> es, PWMEffect :> es) => Word -> Eff es () +periodPath :: FilePath +periodPath = chanPath </> "period" + +dutyCyclePath :: FilePath +dutyCyclePath = chanPath </> "duty_cycle" + +-- This function waits for a file at the given `path` to become writable by +-- the `pwm` user group. A UDEV rule ensures that files in +-- `/sys/class/pwm/pwmchip*` are made writable through a `chown` call. +-- However, because UDEV rules are applied asynchronously, there may be a +-- brief delay before the rule takes effect. This function blocks and +-- repeatedly checks the file's write permissions by calling `fileAccess`. It +-- continues checking until write access is confirmed. +waitWritable :: (Concurrent :> es, Log :> es) => FilePath -> Eff es () +waitWritable path = do + logTrace_ $ "Waiting for " <> pack path <> " to become writable" + untilM_ (threadDelay 1000) $ E.unsafeEff_ (fileAccess path False True False) + +dutyCycle :: (Concurrent :> es, Log :> es, PWMEffect :> es) => Word -> Eff es () dutyCycle dc = do localDomain domain $ logTrace_ $ "Setting duty cycle to " <> pack (show dc) - E.unsafeEff_ $ writeFile dutyCyclePath $ show dc - where - dutyCyclePath = chanPath </> "duty_cycle" + E.unsafeEff_ $ writeFile (chanPath </> "duty_cycle") $ show dc -disable :: (Log :> es, PWMEffect :> es) => Eff es () +disable :: (Concurrent :> es, Log :> es, PWMEffect :> es) => Eff es () disable = do dutyCycle 0 localDomain domain @@ -71,7 +95,8 @@ disable = do $ "Disabling PWM channel " <> pack (show chanIdx) E.unsafeEff_ $ writeFile enablePath "0" -withPWM :: (Log :> es, PWMEffect :> es) => Eff es a -> Eff es a +withPWM :: + (Concurrent :> es, Log :> es, PWMEffect :> es) => Eff es a -> Eff es a withPWM = bracket_ activate disable where activate = do @@ -83,30 +108,31 @@ withPWM = bracket_ activate disable runPWM :: forall env es a. ( HasField "pwmPeriod" env Word + , Concurrent :> es , IOE :> es , Log :> es , Reader env :> es ) => Eff (PWMEffect : es) a -> Eff es a -runPWM action = E.evalStaticRep (PWMEffect ()) $ bracket_ acquire release action +runPWM = E.evalStaticRep (PWMEffect ()) . bracket_ acquire release where - export = pwmchip </> "export" - period = chanPath </> "period" - unexport = pwmchip </> "unexport" acquire = do localDomain domain $ do + waitWritable exportPath + waitWritable unexportPath logTrace_ $ "Exporting channel " <> pack (show chanIdx) <> " on chip " <> pack pwmchip - E.unsafeEff_ $ writeFile export $ show chanIdx - logTrace_ "Giving UDEV a chance to settle" - E.unsafeEff_ $ callCommand "udevadm settle" + E.unsafeEff_ $ writeFile exportPath $ show chanIdx + waitWritable enablePath + waitWritable periodPath + waitWritable dutyCyclePath env <- ask @env logTrace_ $ "Fixing period to " <> pack (show env.pwmPeriod) - E.unsafeEff_ $ writeFile period $ show env.pwmPeriod + E.unsafeEff_ $ writeFile periodPath $ show env.pwmPeriod disable release = do disable @@ -116,4 +142,4 @@ runPWM action = E.evalStaticRep (PWMEffect ()) $ bracket_ acquire release action <> pack (show chanIdx) <> " on chip " <> pack pwmchip - E.unsafeEff_ $ writeFile unexport $ show chanIdx + E.unsafeEff_ $ writeFile unexportPath $ show chanIdx diff --git a/hsm-pwm/hsm-pwm.cabal b/hsm-pwm/hsm-pwm.cabal index 4190975..69b6911 100644 --- a/hsm-pwm/hsm-pwm.cabal +++ b/hsm-pwm/hsm-pwm.cabal @@ -8,11 +8,12 @@ version: 0.1.0.0 library build-depends: , base - , effectful-core + , effectful , filepath , log-effectful - , process + , monad-loops , text + , unix exposed-modules: Hsm.PWM ghc-options: -Wall -Wunused-packages |