Adds PWM effect and dummy gradient service

1 files changed, 120 insertions, 0 deletions

diff --git a/hsm-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs
new file mode 100644
index 0000000..a5e1d27
--- /dev/null
+++ b/hsm-pwm/Hsm/PWM.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.PWM
+  ( PWMEffect
+  , dutyCycle
+  , withPWM
+  , runPWM
+  ) where
+
+import Data.Text (Text, pack)
+import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
+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)
+
+-- The following PWMEffect implementation assumes `dtoverlay=pwm` to be set on
+-- `/boot/config.txt`. On the Pi 5, this enables one active PWM on GPIO 18.
+-- This is channel 2, so the address attribute will be 2. Alternative
+-- configurations with more PWM channels are possible. Consult the following
+-- links for more info:
+--
+-- Modifications to `config.txt`:
+-- https://www.pi4j.com/blog/2024/20240423_pwm_rpi5/#modify-configtxt
+--
+-- SysFS PWM interface:
+-- https://forums.raspberrypi.com/viewtopic.php?t=359251
+--
+-- UDEV setup for non-root access:
+-- https://forums.raspberrypi.com/viewtopic.php?t=316514
+data PWMEffect a b
+
+type instance DispatchOf PWMEffect = Static E.WithSideEffects
+
+newtype instance E.StaticRep PWMEffect =
+  PWMEffect ()
+
+domain :: Text
+domain = "pwm"
+
+pwmchip :: FilePath
+pwmchip = "/sys/class/pwm/pwmchip0"
+
+chanIdx :: Word
+chanIdx = 2
+
+chanPath :: FilePath
+chanPath = pwmchip </> ("pwm" <> show chanIdx)
+
+enablePath :: FilePath
+enablePath = chanPath </> "enable"
+
+dutyCycle :: (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"
+
+disable :: (Log :> es, PWMEffect :> es) => Eff es ()
+disable = do
+  dutyCycle 0
+  localDomain domain
+    $ logTrace_
+    $ "Disabling PWM channel " <> pack (show chanIdx)
+  E.unsafeEff_ $ writeFile enablePath "0"
+
+withPWM :: (Log :> es, PWMEffect :> es) => Eff es a -> Eff es a
+withPWM = bracket_ activate disable
+  where
+    activate = do
+      localDomain domain
+        $ logTrace_
+        $ "Enabling PWM channel " <> pack (show chanIdx)
+      E.unsafeEff_ $ writeFile enablePath "1"
+
+runPWM ::
+     forall env es a.
+     ( HasField "pwmPeriod" env Word
+     , IOE :> es
+     , Log :> es
+     , Reader env :> es
+     )
+  => Eff (PWMEffect : es) a
+  -> Eff es a
+runPWM action = E.evalStaticRep (PWMEffect ()) $ bracket_ acquire release action
+  where
+    export = pwmchip </> "export"
+    period = chanPath </> "period"
+    unexport = pwmchip </> "unexport"
+    acquire = do
+      localDomain domain $ do
+        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"
+        env <- ask @env
+        logTrace_ $ "Fixing period to " <> pack (show env.pwmPeriod)
+        E.unsafeEff_ $ writeFile period $ show env.pwmPeriod
+      disable
+    release = do
+      disable
+      localDomain domain
+        $ logTrace_
+        $ "Unexporting channel "
+            <> pack (show chanIdx)
+            <> " on chip "
+            <> pack pwmchip
+      E.unsafeEff_ $ writeFile unexport $ show chanIdx