From ab4591cb0e074ce98c24645cdb80cb5012aed566 Mon Sep 17 00:00:00 2001 From: Paul Oliver Date: Fri, 7 Feb 2025 17:10:05 +0000 Subject: Initial --- hsm-pwm/Hsm/PWM.hs | 144 ++++++++++++++++++++++++++++++++++++++++++++++++++ hsm-pwm/hsm-pwm.cabal | 21 ++++++++ 2 files changed, 165 insertions(+) create mode 100644 hsm-pwm/Hsm/PWM.hs create mode 100644 hsm-pwm/hsm-pwm.cabal (limited to 'hsm-pwm') 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 diff --git a/hsm-pwm/hsm-pwm.cabal b/hsm-pwm/hsm-pwm.cabal new file mode 100644 index 0000000..8a6c44d --- /dev/null +++ b/hsm-pwm/hsm-pwm.cabal @@ -0,0 +1,21 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-pwm +version: 0.1.0.0 + +library + build-depends: + , base + , filepath + , hsm-log + , io-region + , monad-loops + , text + , unix + + exposed-modules: Hsm.PWM + ghc-options: -Wall -Wunused-packages + extra-libraries: gpiod + default-language: GHC2021 -- cgit v1.2.1