1 files changed, 144 insertions, 0 deletions
diff --git a/hsm-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs
new file mode 100644
index 0000000..1aca773
--- /dev/null
+++ b/hsm-pwm/Hsm/PWM.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.PWM
+  ( PWMHandle
+  , PWMChannel(PWM2, PWM3)
+  , PWMConfig(PWMConfig, period, dutyCycle)
+  , defaultPWMConfig
+  , setPeriod
+  , setDutyCycle
+  , allocatePWM
+  ) where
+
+import Control.Concurrent (threadDelay)
+import Control.IO.Region (Region, alloc_)
+import Control.Monad.Loops (untilM_)
+import Data.Text (Text, pack)
+import Hsm.Log qualified as L
+import System.FilePath ((</>))
+import System.Posix.Files (fileAccess)
+
+-- This data type defines a placeholder `PWMHandle` to ensure that PWM actions
+-- occur only after the `allocatePWM` function has been called. The empty
+-- handle acts as a flag to enforce the correct order of operations.
+data PWMHandle =
+  PWMHandle
+
+-- This PWM controller assumes `dtoverlay=pwm-2chan` is set in
+-- `/boot/config.txt`, enabling PWM on GPIO 18 (channel 2) and GPIO 19
+-- (channel 3) for the Pi 5. Alternative configurations with additional PWM
+-- channels are possible. For more information, consult the following links:
+--
+-- - 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 PWMChannel
+  = PWM2
+  | PWM3
+  deriving (Bounded, Enum, Show)
+
+data PWMConfig = PWMConfig
+  { period :: Int
+  , dutyCycle :: Int
+  }
+
+defaultPWMConfig :: PWMConfig
+defaultPWMConfig = PWMConfig {period = 1000000, dutyCycle = 0}
+
+logMsg :: Text -> IO ()
+logMsg = L.logMsg ["pwm"]
+
+chipPath :: FilePath
+chipPath = "/sys/class/pwm/pwmchip0"
+
+channelIndex :: PWMChannel -> Int
+channelIndex = read . drop 3 . show
+
+channelPaths :: PWMChannel -> (FilePath, FilePath, FilePath)
+channelPaths channel = (enablePath, periodPath, dutyCyclePath)
+  where
+    channelPath = chipPath </> ("pwm" <> show (channelIndex channel))
+    enablePath = channelPath </> "enable"
+    periodPath = channelPath </> "period"
+    dutyCyclePath = channelPath </> "duty_cycle"
+
+setPeriod :: PWMHandle -> PWMChannel -> Int -> IO ()
+setPeriod _ channel period = do
+  logMsg
+    $ "Setting period on channel "
+        <> pack (show channel)
+        <> " to "
+        <> pack (show period)
+  writeFile periodPath $ show period
+  where
+    (_, periodPath, _) = channelPaths channel
+
+setDutyCycle :: PWMHandle -> PWMChannel -> Int -> IO ()
+setDutyCycle _ channel dutyCycle = do
+  logMsg
+    $ "Setting duty cycle on channel "
+        <> pack (show channel)
+        <> " to "
+        <> pack (show dutyCycle)
+  writeFile dutyCyclePath $ show dutyCycle
+  where
+    (_, _, dutyCyclePath) = channelPaths channel
+
+allocatePWM :: Region -> IO PWMHandle
+allocatePWM region = alloc_ region acquire $ const release
+  where
+    exportPath = chipPath </> "export"
+    unexportPath = chipPath </> "unexport"
+    -- 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 path = do
+      logMsg $ "Waiting for " <> pack path <> " to become writable"
+      untilM_ (threadDelay 1000) $ fileAccess path False True False
+    allChannels = [minBound .. maxBound]
+    -- Acquire PWM channels
+    acquireChannel channel = do
+      logMsg
+        $ "Exporting channel "
+            <> pack (show channel)
+            <> " on chip "
+            <> pack chipPath
+      writeFile exportPath $ show (channelIndex channel)
+      let (enablePath, periodPath, dutyCyclePath) = channelPaths channel
+      waitWritable enablePath
+      waitWritable periodPath
+      waitWritable dutyCyclePath
+      logMsg $ "Enabling channel " <> pack (show channel)
+      writeFile enablePath "1"
+      -- Sets default PWM period to 1 us
+      setPeriod PWMHandle channel 1000
+      setDutyCycle PWMHandle channel 0
+    acquire = do
+      waitWritable exportPath
+      waitWritable unexportPath
+      mapM_ acquireChannel allChannels
+      return PWMHandle
+    -- Release PWM channels
+    releaseChannel channel = do
+      let (enablePath, _, dutyCyclePath) = channelPaths channel
+      logMsg $ "Setting duty cycle to 0 on channel " <> pack (show channel)
+      writeFile dutyCyclePath "0"
+      logMsg $ "Disabling channel " <> pack (show channel)
+      writeFile enablePath "0"
+      logMsg
+        $ "Unexporting channel "
+            <> pack (show channel)
+            <> " on chip "
+            <> pack chipPath
+      writeFile unexportPath $ show (channelIndex channel)
+    release = mapM_ releaseChannel allChannels