From c8b355a9163e8aec346d50e84cff75d0745ba754 Mon Sep 17 00:00:00 2001
From: Paul Oliver <contact@pauloliver.dev>
Date: Wed, 29 Jan 2025 22:13:45 +0000
Subject: Adds monitoring of PWM file permission changes

---
 hsm-pwm/Hsm/PWM.hs | 58 +++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 42 insertions(+), 16 deletions(-)

(limited to 'hsm-pwm/Hsm/PWM.hs')

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
-- 
cgit v1.2.1