1 files changed, 136 insertions, 0 deletions
diff --git a/hsm-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs
new file mode 100644
index 0000000..ad4c052
--- /dev/null
+++ b/hsm-pwm/Hsm/PWM.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.PWM
+  ( PWMHandle
+  , PWMChannel(PWM2, PWM3)
+  , setFrequency
+  , 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)
+
+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"
+
+setEnable :: PWMChannel -> Bool -> IO ()
+setEnable channel enable = do
+  logMsg $ "Setting " <> pack enablePath <> " to " <> pack (show enable)
+  writeFile enablePath enableString
+  where
+    (enablePath, _, _) = channelPaths channel
+    enableString = show $ fromEnum enable
+
+setPeriod :: PWMChannel -> Int -> IO ()
+setPeriod channel period = do
+  logMsg $ "Setting " <> pack periodPath <> " to " <> pack (show period)
+  writeFile periodPath $ show period
+  where
+    (_, periodPath, _) = channelPaths channel
+
+setDutyCycle :: PWMChannel -> Int -> IO ()
+setDutyCycle channel dutyCycle = do
+  logMsg $ "Setting " <> pack dutyCyclePath <> " to " <> pack (show dutyCycle)
+  writeFile dutyCyclePath $ show dutyCycle
+  where
+    (_, _, dutyCyclePath) = channelPaths channel
+
+setFrequency :: PWMHandle -> PWMChannel -> Int -> IO ()
+setFrequency _ channel frequency = do
+  logMsg
+    $ "Setting frequency on channel "
+        <> pack (show channel)
+        <> " to "
+        <> pack (show frequency)
+  setEnable channel False
+  setPeriod channel frequency
+  setDutyCycle channel $ frequency `div` 2
+  setEnable channel True
+
+allocatePWM :: Region -> (PWMChannel -> Int) -> IO PWMHandle
+allocatePWM region mapper = 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
+      setFrequency PWMHandle channel $ mapper channel
+    acquire = do
+      waitWritable exportPath
+      waitWritable unexportPath
+      mapM_ acquireChannel allChannels
+      return PWMHandle
+    -- Release PWM channels
+    releaseChannel channel = do
+      setEnable channel False
+      logMsg
+        $ "Unexporting channel "
+            <> pack (show channel)
+            <> " on chip "
+            <> pack chipPath
+      writeFile unexportPath $ show (channelIndex channel)
+    release = mapM_ releaseChannel allChannels