diff options
| -rw-r--r-- | hsm-dummy-gradient/Main.hs | 48 | ||||
| -rw-r--r-- | hsm-dummy-gradient/hsm-dummy-gradient.cabal | 24 | ||||
| -rw-r--r-- | hsm-pwm/Hsm/PWM.hs | 120 | ||||
| -rw-r--r-- | hsm-pwm/hsm-pwm.cabal | 19 | ||||
| -rw-r--r-- | servconf.yaml | 4 | ||||
| -rw-r--r-- | stack.yaml | 2 |
6 files changed, 217 insertions, 0 deletions
diff --git a/hsm-dummy-gradient/Main.hs b/hsm-dummy-gradient/Main.hs new file mode 100644 index 0000000..05ead49 --- /dev/null +++ b/hsm-dummy-gradient/Main.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +import Control.Monad (forM_, forever) +import Data.Function ((&)) +import Data.Text (Text) +import Effectful (Eff, (:>), runEff) +import Effectful.Concurrent (Concurrent, runConcurrent, threadDelay) +import Effectful.Log (Log, runLog) +import Effectful.Reader.Static (Reader, ask, runReader) +import Hsm.Core.App (launch) +import Hsm.Core.Env (deriveFromYaml) +import Hsm.PWM (PWMEffect, dutyCycle, runPWM, withPWM) +import System.IO.Echo (withoutInputEcho) + +data Env = Env + { name :: Text + , pwmPeriod :: Word + , stepDelay :: Word + } + +$(deriveFromYaml ''Env) + +pwmLoop :: + (Concurrent :> es, Log :> es, PWMEffect :> es, Reader Env :> es) + => Eff es () +pwmLoop = do + env <- ask @Env + withPWM + $ forever + $ forM_ [0,env.pwmPeriod `div` 10 .. env.pwmPeriod] + $ \dc -> do + threadDelay $ fromIntegral env.stepDelay + dutyCycle dc + +-- Dummy gradient service: +-- Simple test for PWM control. Increases duty-cycle gradually on default PWM +-- channel. +main :: IO () +main = + launch @Env "dummy-gradient" withoutInputEcho $ \env logger level -> + pwmLoop + & runPWM @Env + & runConcurrent + & runLog env.name logger level + & runReader env + & runEff diff --git a/hsm-dummy-gradient/hsm-dummy-gradient.cabal b/hsm-dummy-gradient/hsm-dummy-gradient.cabal new file mode 100644 index 0000000..1f895a0 --- /dev/null +++ b/hsm-dummy-gradient/hsm-dummy-gradient.cabal @@ -0,0 +1,24 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-dummy-gradient +version: 0.1.0.0 + +executable dummy-gradient + build-depends: + , base + , echo + , effectful + , hsm-core + , hsm-pwm + , log-effectful + , text + + main-is: Main.hs + ghc-options: -Wall -Wunused-packages + + if !arch(x86_64) + ghc-options: -optl=-mno-fix-cortex-a53-835769 + + default-language: GHC2021 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 diff --git a/hsm-pwm/hsm-pwm.cabal b/hsm-pwm/hsm-pwm.cabal new file mode 100644 index 0000000..4190975 --- /dev/null +++ b/hsm-pwm/hsm-pwm.cabal @@ -0,0 +1,19 @@ +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 + , effectful-core + , filepath + , log-effectful + , process + , text + + exposed-modules: Hsm.PWM + ghc-options: -Wall -Wunused-packages + default-language: GHC2021 diff --git a/servconf.yaml b/servconf.yaml index a014ade..b2b01cd 100644 --- a/servconf.yaml +++ b/servconf.yaml @@ -12,6 +12,10 @@ dummy-fail: alive: 1000000 name: fail pubEp: tcp://0.0.0.0:10002 +dummy-gradient: + name: gradient + pwmPeriod: 1000000 + stepDelay: 100000 dummy-poller: name: poller period: 3000000 @@ -7,9 +7,11 @@ packages: - hsm-core - hsm-dummy-blinker - hsm-dummy-fail + - hsm-dummy-gradient - hsm-dummy-poller - hsm-dummy-pulser - hsm-dummy-receiver - hsm-gpio + - hsm-pwm - hsm-status snapshot: lts-23.3 |