aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore1
-rw-r--r--README.md30
-rw-r--r--hsm-bin/Test/Drive.hs23
-rw-r--r--hsm-bin/Test/Status.hs22
-rw-r--r--hsm-bin/hsm-bin.cabal32
-rw-r--r--hsm-drive/Hsm/Drive.hs105
-rw-r--r--hsm-drive/hsm-drive.cabal18
-rw-r--r--hsm-gpio/Hsm/GPIO.hs163
-rw-r--r--hsm-gpio/Hsm/GPIO/Lib.hsc116
-rw-r--r--hsm-gpio/hsm-gpio.cabal21
-rw-r--r--hsm-log/Hsm/Log.hs15
-rw-r--r--hsm-log/hsm-log.cabal17
-rw-r--r--hsm-pwm/Hsm/PWM.hs144
-rw-r--r--hsm-pwm/hsm-pwm.cabal21
-rw-r--r--hsm-readline/Hsm/Readline.hs50
-rw-r--r--hsm-readline/hsm-readline.cabal18
-rw-r--r--hsm-status/Hsm/Status.hs47
-rw-r--r--hsm-status/hsm-status.cabal17
-rw-r--r--stack.yaml9
-rw-r--r--stack.yaml.lock12
-rw-r--r--sysconf/98-gpiod.rules2
-rw-r--r--sysconf/99-pwm.rules12
-rw-r--r--sysconf/config.txt57
23 files changed, 952 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..795e31a
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+**/.stack-work/
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..8d22b40
--- /dev/null
+++ b/README.md
@@ -0,0 +1,30 @@
+# HsMouse
+Experimental control software for robotics, tested on Raspberry Pi 5.
+
+## System Configuration:
+To configure the system, the files in the `sysconf` directory must be
+installed:
+
+1. Copy the UDEV `*.rule` files into `/etc/udev/rules.d`.
+2. Copy `config.txt` to `/boot`.
+3. Reboot the Raspberry Pi for the changes to take effect.
+
+## GPIO and PWM Access Without Root:
+To enable GPIO and PWM access without root privileges on the Raspberry Pi 5,
+follow these steps:
+
+1. Create two new user groups: `gpiod` and `pwm`.
+2. Add your user to both groups.
+3. The UDEV rules installed previously will grant the `gpiod` and `pwm` user
+groups permission to access the respective subsystems.
+
+This configuration ensures that GPIO and PWM operations can be performed
+without needing root access.
+
+## Build Instructions:
+1. Install [`stack`](https://docs.haskellstack.org/en/stable/). It’s
+recommended to use [`ghcup`](https://www.haskell.org/ghcup/) for installation.
+2. Run `stack build` to compile the libraries and executables.
+
+> Note: You may need to install system dependencies on your host first (e.g.,
+> `libgpiod`, etc.)
diff --git a/hsm-bin/Test/Drive.hs b/hsm-bin/Test/Drive.hs
new file mode 100644
index 0000000..899964c
--- /dev/null
+++ b/hsm-bin/Test/Drive.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.IO.Region (region)
+import Control.Monad.Loops (whileJust_)
+import Hsm.Drive (DriveEnv, drive, driveEnvDefault)
+import Hsm.GPIO (allocateGPIO)
+import Hsm.PWM qualified as P
+import Hsm.Readline (allocateReadline, readline)
+
+newtype Env = Env
+ { driveEnv :: DriveEnv
+ }
+
+main :: IO ()
+main =
+ region $ \ioRegion -> do
+ lineRequest <- allocateGPIO ioRegion "test-drive"
+ pwmHandle <- P.allocatePWM ioRegion
+ handle <- allocateReadline ioRegion
+ whileJust_ (readline handle)
+ $ drive pwmHandle lineRequest
+ $ Env driveEnvDefault
diff --git a/hsm-bin/Test/Status.hs b/hsm-bin/Test/Status.hs
new file mode 100644
index 0000000..bc05eca
--- /dev/null
+++ b/hsm-bin/Test/Status.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.IO.Region (region)
+import Control.Monad.Loops (whileJust_)
+import Hsm.GPIO (allocateGPIO)
+import Hsm.PWM qualified as P
+import Hsm.Readline (allocateReadline, readline)
+import Hsm.Status (StatusEnv, status, statusEnvDefault)
+
+newtype Env = Env
+ { statusEnv :: StatusEnv
+ }
+
+main :: IO ()
+main =
+ region $ \ioRegion -> do
+ lineRequest <- allocateGPIO ioRegion "test-status"
+ pwmHandle <- P.allocatePWM ioRegion
+ handle <- allocateReadline ioRegion
+ whileJust_ (readline handle)
+ $ status lineRequest pwmHandle
+ $ Env statusEnvDefault
diff --git a/hsm-bin/hsm-bin.cabal b/hsm-bin/hsm-bin.cabal
new file mode 100644
index 0000000..de7853f
--- /dev/null
+++ b/hsm-bin/hsm-bin.cabal
@@ -0,0 +1,32 @@
+cabal-version: 3.4
+author: Paul Oliver
+build-type: Simple
+maintainer: contact@pauloliver.dev
+name: hsm-bin
+version: 0.1.0.0
+
+common test-executable
+ build-depends:
+ , base
+ , hsm-gpio
+ , hsm-pwm
+ , hsm-readline
+ , io-region
+ , monad-loops
+
+ ghc-options: -Wall -Wunused-packages
+
+ if !arch(x86_64)
+ ghc-options: -optl=-mno-fix-cortex-a53-835769
+
+ default-language: GHC2021
+
+executable test-status
+ import: test-executable
+ build-depends: hsm-status
+ main-is: Test/Status.hs
+
+executable test-drive
+ import: test-executable
+ build-depends: hsm-drive
+ main-is: Test/Drive.hs
diff --git a/hsm-drive/Hsm/Drive.hs b/hsm-drive/Hsm/Drive.hs
new file mode 100644
index 0000000..dffb8dc
--- /dev/null
+++ b/hsm-drive/Hsm/Drive.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.Drive
+ ( Speed(Slow, Medium, Fast)
+ , Direction(Forward, Backward)
+ , Duration
+ , DriveEnv(..)
+ , Command(Move)
+ , pwmMapperDefault
+ , driveEnvDefault
+ , drive
+ ) where
+
+import Control.Concurrent (threadDelay)
+import Data.Text (pack)
+import Data.Typeable (Typeable)
+import Foreign.Ptr (Ptr)
+import GHC.Records (HasField)
+import Hsm.GPIO (GPIO(..), LineRequest, active, inactive, setPins)
+import Hsm.Log qualified as L
+import Hsm.PWM (PWMChannel(PWM3), PWMHandle, setDutyCycle)
+
+data Speed
+ = Slow
+ | Medium
+ | Fast
+ deriving (Read, Show, Typeable)
+
+data Direction
+ = Forward
+ | Backward
+ deriving (Read, Show, Typeable)
+
+type Duration = Float
+
+data Command
+ = Move Speed Direction Duration
+ | Stop Duration
+ deriving (Read, Show, Typeable)
+
+data DriveEnv = DriveEnv
+ { gpioM1F :: GPIO
+ , gpioM1B :: GPIO
+ , gpioM2F :: GPIO
+ , gpioM2B :: GPIO
+ , gpioM3F :: GPIO
+ , gpioM3B :: GPIO
+ , gpioM4F :: GPIO
+ , gpioM4B :: GPIO
+ , pwmChannel :: PWMChannel
+ , pwmPeriod :: Int
+ , pwmMapper :: Speed -> Int
+ }
+
+pwmMapperDefault :: Speed -> Int
+pwmMapperDefault Slow = 500000
+pwmMapperDefault Medium = 750000
+pwmMapperDefault Fast = 1000000
+
+driveEnvDefault :: DriveEnv
+driveEnvDefault =
+ DriveEnv
+ { gpioM1F = GPIO24
+ , gpioM1B = GPIO25
+ , gpioM2F = GPIO8
+ , gpioM2B = GPIO7
+ , gpioM3F = GPIO12
+ , gpioM3B = GPIO16
+ , gpioM4F = GPIO20
+ , gpioM4B = GPIO21
+ , pwmChannel = PWM3
+ , pwmPeriod = 1000000 -- 1ms
+ , pwmMapper = pwmMapperDefault
+ }
+
+drive ::
+ HasField "driveEnv" env DriveEnv
+ => PWMHandle
+ -> Ptr LineRequest
+ -> env
+ -> [Command]
+ -> IO Bool
+drive pwmHandle lineRequest env commands = do
+ mapM_ runCommand commands
+ return True
+ where
+ logMsg = L.logMsg ["drive"]
+ pinsForward = [gpioM1F, gpioM2F, gpioM3F, gpioM4F] <*> [env.driveEnv]
+ pinsBackward = [gpioM1B, gpioM2B, gpioM3B, gpioM4B] <*> [env.driveEnv]
+ toMicroSeconds = round . (* 1000000)
+ runCommand command = do
+ logMsg $ "Running command: " <> pack (show command)
+ case command of
+ (Move speed direction duration) -> do
+ case direction of
+ Forward -> setPins lineRequest pinsForward active
+ Backward -> setPins lineRequest pinsBackward active
+ setDutyCycle pwmHandle env.driveEnv.pwmChannel
+ $ env.driveEnv.pwmMapper speed
+ threadDelay $ toMicroSeconds duration
+ setDutyCycle pwmHandle env.driveEnv.pwmChannel 0
+ setPins lineRequest (pinsForward <> pinsBackward) inactive
+ (Stop duration) -> threadDelay $ toMicroSeconds duration
diff --git a/hsm-drive/hsm-drive.cabal b/hsm-drive/hsm-drive.cabal
new file mode 100644
index 0000000..697e286
--- /dev/null
+++ b/hsm-drive/hsm-drive.cabal
@@ -0,0 +1,18 @@
+cabal-version: 3.4
+author: Paul Oliver
+build-type: Simple
+maintainer: contact@pauloliver.dev
+name: hsm-drive
+version: 0.1.0.0
+
+library
+ build-depends:
+ , base
+ , hsm-gpio
+ , hsm-log
+ , hsm-pwm
+ , text
+
+ exposed-modules: Hsm.Drive
+ ghc-options: -Wall -Wunused-packages
+ default-language: GHC2021
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
new file mode 100644
index 0000000..dd69122
--- /dev/null
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.GPIO
+ ( G.active
+ , G.inactive
+ , G.LineRequest
+ , GPIO(..)
+ , setPins
+ , setAllPins
+ , allocateGPIO
+ ) where
+
+import Control.IO.Region (Region, alloc, alloc_, defer, free)
+import Control.Monad (forM_, void)
+import Data.ByteString (useAsCString)
+import Data.Text (Text, pack)
+import Data.Text.Encoding (encodeUtf8)
+import Data.Vector.Storable qualified as V
+import Foreign.C.Types (CSize(CSize), CUInt(CUInt))
+import Foreign.Ptr (Ptr)
+import Hsm.GPIO.Lib qualified as G
+import Hsm.Log qualified as L
+
+logMsg :: Text -> IO ()
+logMsg = L.logMsg ["gpio"]
+
+data GPIO
+ = GPIO2
+ | GPIO3
+ | GPIO4
+ | GPIO5
+ | GPIO6
+ | GPIO7
+ | GPIO8
+ | GPIO9
+ | GPIO10
+ | GPIO11
+ | GPIO12
+ | GPIO13
+ | GPIO14
+ | GPIO15
+ | GPIO16
+ | GPIO17
+ -- | GPIO18 -- reserved for PWM
+ -- | GPIO19 -- reserved for PWM
+ | GPIO20
+ | GPIO21
+ | GPIO22
+ | GPIO23
+ | GPIO24
+ | GPIO25
+ | GPIO26
+ | GPIO27
+ deriving (Bounded, Enum, Show)
+
+pinLine :: GPIO -> CUInt
+pinLine = CUInt . read . drop 4 . show
+
+allPins :: [GPIO]
+allPins = [minBound .. maxBound]
+
+allLines :: [CUInt]
+allLines = pinLine <$> allPins
+
+setPins :: Ptr G.LineRequest -> [GPIO] -> G.LineValue -> IO ()
+setPins lineRequest pins lineValue = do
+ logMsg
+ $ "Setting pin(s) "
+ <> pack (show pins)
+ <> " to state "
+ <> pack (show lineValue)
+ forM_ pins $ \pin -> G.lineRequestSetValue lineRequest (pinLine pin) lineValue
+
+setAllPins :: Ptr G.LineRequest -> G.LineValue -> IO ()
+setAllPins lineRequest lineValue = do
+ logMsg
+ $ "Setting all pins "
+ <> pack (show allPins)
+ <> " to state "
+ <> pack (show lineValue)
+ void
+ $ V.unsafeWith (V.replicate (length allPins) lineValue)
+ $ G.lineRequestSetValues lineRequest
+
+allocateGPIO :: Region -> Text -> IO (Ptr G.LineRequest)
+allocateGPIO region consumer = do
+ (chip, chipKey) <- allocateChip
+ (lineSettings, lineSettingsKey) <- allocateLineSettings
+ (lineConfig, lineConfigKey) <- allocateLineConfig lineSettings
+ (requestConfig, requestConfigKey) <- allocateRequestConfig
+ lineRequest <- allocateLineRequest chip requestConfig lineConfig
+ free requestConfigKey
+ free lineConfigKey
+ free lineSettingsKey
+ free chipKey
+ defer region $ setAllPins lineRequest G.inactive
+ return lineRequest
+ where
+ chipPath = "/dev/gpiochip0"
+ -- GPIO chip
+ chipOpen = do
+ logMsg $ "Opening GPIO chip " <> chipPath
+ useAsCString (encodeUtf8 chipPath) G.chipOpen
+ chipClose chip = do
+ logMsg $ "Closing GPIO chip " <> chipPath
+ G.chipClose chip
+ allocateChip = alloc region chipOpen chipClose
+ -- Line settings
+ lineSettingsNew = do
+ logMsg "Allocating line settings"
+ lineSettings <- G.lineSettingsNew
+ logMsg $ "With direction set to " <> pack (show G.output)
+ void $ G.lineSettingsSetDirection lineSettings G.output
+ logMsg $ "With output set to " <> pack (show G.inactive)
+ void $ G.lineSettingsSetOutputValue lineSettings G.inactive
+ return lineSettings
+ lineSettingsFree lineSettings = do
+ logMsg "Freeing line settings"
+ G.lineSettingsFree lineSettings
+ allocateLineSettings = alloc region lineSettingsNew lineSettingsFree
+ -- Line config
+ lineConfigNew lineSettings = do
+ logMsg "Allocating line config"
+ logMsg $ "With GPIO pins " <> pack (show allPins)
+ lineConfig <- G.lineConfigNew
+ void
+ $ V.unsafeWith (V.fromList allLines)
+ $ \pinsVector ->
+ G.lineConfigAddLineSettings
+ lineConfig
+ pinsVector
+ (CSize $ fromIntegral $ length allPins)
+ lineSettings
+ return lineConfig
+ lineConfigFree lineConfig = do
+ logMsg "Freeing line config"
+ G.lineConfigFree lineConfig
+ allocateLineConfig lineSettings =
+ alloc region (lineConfigNew lineSettings) lineConfigFree
+ -- Request config
+ requestConfigNew = do
+ logMsg "Allocating request config"
+ logMsg $ "With consumer " <> consumer
+ requestConfig <- G.requestConfigNew
+ useAsCString (encodeUtf8 consumer)
+ $ G.requestConfigSetConsumer requestConfig
+ return requestConfig
+ requestConfigFree requestConfig = do
+ logMsg "Freeing request config"
+ G.requestConfigFree requestConfig
+ allocateRequestConfig = alloc region requestConfigNew requestConfigFree
+ -- Line request
+ requestLines chip requestConfig lineConfig = do
+ logMsg "Allocating line request"
+ G.requestLines chip requestConfig lineConfig
+ lineRequestRelease lineRequest = do
+ logMsg "Releasing line request"
+ G.lineRequestRelease lineRequest
+ allocateLineRequest chip requestConfig lineConfig =
+ alloc_
+ region
+ (requestLines chip requestConfig lineConfig)
+ lineRequestRelease
diff --git a/hsm-gpio/Hsm/GPIO/Lib.hsc b/hsm-gpio/Hsm/GPIO/Lib.hsc
new file mode 100644
index 0000000..6716f3a
--- /dev/null
+++ b/hsm-gpio/Hsm/GPIO/Lib.hsc
@@ -0,0 +1,116 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-- This module provides C bindings to the `gpiod` library for direct GPIO pin
+-- control. It includes bindings only for the C functions that are currently
+-- used. In the future, creating a complete set of bindings for the entire
+-- `gpiod` library as an external package would be a valuable contribution to
+-- Hackage.
+
+module Hsm.GPIO.Lib
+ ( chipOpen
+ , chipClose
+ , input
+ , output
+ , LineValue
+ , active
+ , inactive
+ , lineSettingsNew
+ , lineSettingsFree
+ , lineSettingsSetDirection
+ , lineSettingsSetOutputValue
+ , lineConfigNew
+ , lineConfigFree
+ , lineConfigAddLineSettings
+ , requestConfigNew
+ , requestConfigFree
+ , requestConfigSetConsumer
+ , requestLines
+ , LineRequest
+ , lineRequestRelease
+ , lineRequestSetValue
+ , lineRequestSetValues
+ ) where
+
+#include <gpiod.h>
+
+import Foreign.C.String (CString)
+import Foreign.C.Types (CInt(CInt), CSize(CSize), CUInt(CUInt))
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (Storable)
+
+data Chip
+
+foreign import ccall unsafe "gpiod.h gpiod_chip_open"
+ chipOpen :: CString -> IO (Ptr Chip)
+
+foreign import ccall unsafe "gpiod.h gpiod_chip_close"
+ chipClose :: Ptr Chip -> IO ()
+
+data LineSettings
+
+newtype LineDirection =
+ LineDirection CInt
+ deriving (Show)
+
+#{enum LineDirection, LineDirection
+ , input = GPIOD_LINE_DIRECTION_INPUT
+ , output = GPIOD_LINE_DIRECTION_OUTPUT
+}
+
+newtype LineValue =
+ LineValue CInt
+ deriving (Show, Storable)
+
+#{enum LineValue, LineValue
+ , active = GPIOD_LINE_VALUE_ACTIVE
+ , inactive = GPIOD_LINE_VALUE_INACTIVE
+}
+
+foreign import ccall unsafe "gpiod.h gpiod_line_settings_new"
+ lineSettingsNew :: IO (Ptr LineSettings)
+
+foreign import ccall unsafe "gpiod.h gpiod_line_settings_free"
+ lineSettingsFree :: Ptr LineSettings -> IO ()
+
+foreign import ccall unsafe "gpiod.h gpiod_line_settings_set_direction"
+ lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
+
+foreign import ccall unsafe "gpiod.h gpiod_line_settings_set_output_value"
+ lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
+
+data LineConfig
+
+foreign import ccall unsafe "gpiod.h gpiod_line_config_new"
+ lineConfigNew :: IO (Ptr LineConfig)
+
+foreign import ccall unsafe "gpiod.h gpiod_line_config_free"
+ lineConfigFree :: Ptr LineConfig -> IO ()
+
+foreign import ccall unsafe "gpiod.d gpiod_line_config_add_line_settings"
+ lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
+
+data RequestConfig
+
+foreign import ccall unsafe "gpiod.h gpiod_request_config_new"
+ requestConfigNew :: IO (Ptr RequestConfig)
+
+foreign import ccall unsafe "gpiod.h gpiod_request_config_free"
+ requestConfigFree :: Ptr RequestConfig -> IO ()
+
+foreign import ccall unsafe "gpiod.h gpiod_request_config_set_consumer"
+ requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
+
+data LineRequest
+
+foreign import ccall unsafe "gpiod.h gpiod_chip_request_lines"
+ requestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
+
+foreign import ccall unsafe "gpiod.h gpiod_line_request_release"
+ lineRequestRelease :: Ptr LineRequest -> IO ()
+
+foreign import ccall unsafe "gpiod.h gpiod_line_request_set_value"
+ lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
+
+foreign import ccall unsafe "gpiod.h gpiod_line_request_set_values"
+ lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
diff --git a/hsm-gpio/hsm-gpio.cabal b/hsm-gpio/hsm-gpio.cabal
new file mode 100644
index 0000000..786977a
--- /dev/null
+++ b/hsm-gpio/hsm-gpio.cabal
@@ -0,0 +1,21 @@
+cabal-version: 3.4
+author: Paul Oliver
+build-type: Simple
+maintainer: contact@pauloliver.dev
+name: hsm-gpio
+version: 0.1.0.0
+
+library
+ build-depends:
+ , base
+ , bytestring
+ , hsm-log
+ , io-region
+ , text
+ , vector
+
+ exposed-modules: Hsm.GPIO
+ other-modules: Hsm.GPIO.Lib
+ ghc-options: -Wall -Wunused-packages
+ extra-libraries: gpiod
+ default-language: GHC2021
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
new file mode 100644
index 0000000..0f388be
--- /dev/null
+++ b/hsm-log/Hsm/Log.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.Log
+ ( logMsg
+ ) where
+
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.ISO8601 (formatISO8601Millis)
+
+logMsg :: [T.Text] -> T.Text -> IO ()
+logMsg domain msg = do
+ time <- T.pack . formatISO8601Millis <$> getCurrentTime
+ T.putStrLn $ T.unwords [time, "[" <> T.intercalate "/" domain <> "]", msg]
diff --git a/hsm-log/hsm-log.cabal b/hsm-log/hsm-log.cabal
new file mode 100644
index 0000000..65279db
--- /dev/null
+++ b/hsm-log/hsm-log.cabal
@@ -0,0 +1,17 @@
+cabal-version: 3.4
+author: Paul Oliver
+build-type: Simple
+maintainer: contact@pauloliver.dev
+name: hsm-log
+version: 0.1.0.0
+
+library
+ build-depends:
+ , base
+ , iso8601-time
+ , text
+ , time
+
+ exposed-modules: Hsm.Log
+ ghc-options: -Wall -Wunused-packages
+ default-language: GHC2021
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
diff --git a/hsm-readline/Hsm/Readline.hs b/hsm-readline/Hsm/Readline.hs
new file mode 100644
index 0000000..8a0c232
--- /dev/null
+++ b/hsm-readline/Hsm/Readline.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.Readline
+ ( readline
+ , allocateReadline
+ ) where
+
+import Control.IO.Region (Region, alloc_)
+import Data.Text (Text, pack)
+import Data.Typeable (Proxy(Proxy), Typeable, typeRep)
+import Hsm.Log qualified as L
+import System.Console.Haskeline qualified as H
+import System.Console.Haskeline.IO qualified as H
+import Text.Read (readEither)
+
+logMsg :: Text -> IO ()
+logMsg = L.logMsg ["readline"]
+
+readline ::
+ forall a. (Read a, Show a, Typeable a)
+ => H.InputState
+ -> IO (Maybe a)
+readline handle = do
+ logMsg $ "Expecting value of type " <> pack (show $ typeRep $ Proxy @a)
+ valueMaybe <- queryInput
+ maybe (return Nothing) parseValueStr valueMaybe
+ where
+ queryInput =
+ H.queryInput handle
+ $ H.handleInterrupt (return Nothing)
+ $ H.withInterrupt
+ $ H.getInputLine "% "
+ parseValueStr valueStr =
+ case readEither @a valueStr of
+ Right commandValue -> do
+ logMsg $ "Parsed value " <> pack (show commandValue)
+ return $ Just commandValue
+ Left err -> do
+ logMsg $ pack err
+ readline handle
+
+allocateReadline :: Region -> IO H.InputState
+allocateReadline region = alloc_ region initializeInput cancelInput
+ where
+ initializeInput = do
+ logMsg "Initializing input with default settings"
+ H.initializeInput H.defaultSettings
+ cancelInput handle = do
+ logMsg "Cancelling input"
+ H.cancelInput handle
diff --git a/hsm-readline/hsm-readline.cabal b/hsm-readline/hsm-readline.cabal
new file mode 100644
index 0000000..4532219
--- /dev/null
+++ b/hsm-readline/hsm-readline.cabal
@@ -0,0 +1,18 @@
+cabal-version: 3.4
+author: Paul Oliver
+build-type: Simple
+maintainer: contact@pauloliver.dev
+name: hsm-readline
+version: 0.1.0.0
+
+library
+ build-depends:
+ , base
+ , haskeline
+ , hsm-log
+ , io-region
+ , text
+
+ exposed-modules: Hsm.Readline
+ ghc-options: -Wall -Wunused-packages
+ default-language: GHC2021
diff --git a/hsm-status/Hsm/Status.hs b/hsm-status/Hsm/Status.hs
new file mode 100644
index 0000000..94b6351
--- /dev/null
+++ b/hsm-status/Hsm/Status.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hsm.Status
+ ( StatusEnv(..)
+ , statusEnvDefault
+ , status
+ ) where
+
+import Foreign.Ptr (Ptr)
+import GHC.Records (HasField)
+import Hsm.GPIO (GPIO(..), LineRequest, active, inactive, setPins)
+import Hsm.Log qualified as L
+import Hsm.PWM (PWMChannel(PWM2), PWMHandle, setDutyCycle, setPeriod)
+
+data StatusEnv = StatusEnv
+ { gpioError :: GPIO
+ , gpioOK :: GPIO
+ }
+
+statusEnvDefault :: StatusEnv
+statusEnvDefault = StatusEnv {gpioError = GPIO17, gpioOK = GPIO27}
+
+status ::
+ HasField "statusEnv" env StatusEnv
+ => Ptr LineRequest
+ -> PWMHandle
+ -> env
+ -> [Bool]
+ -> IO ()
+status lineRequest pwmHandle env signals = do
+ setDutyCycle pwmHandle PWM2 pwmDutyCycle
+ setPeriod pwmHandle PWM2 pwmPeriod
+ if and signals
+ then do
+ logMsg "All signals OK"
+ setPins lineRequest [env.statusEnv.gpioError] inactive
+ setPins lineRequest [env.statusEnv.gpioOK] active
+ else do
+ logMsg "Error signal received"
+ setPins lineRequest [env.statusEnv.gpioError] active
+ setPins lineRequest [env.statusEnv.gpioOK] inactive
+ where
+ logMsg = L.logMsg ["status"]
+ pwmDutyCycle = 1000000000
+ pwmPeriod = 2000000000
diff --git a/hsm-status/hsm-status.cabal b/hsm-status/hsm-status.cabal
new file mode 100644
index 0000000..7d75e29
--- /dev/null
+++ b/hsm-status/hsm-status.cabal
@@ -0,0 +1,17 @@
+cabal-version: 3.4
+author: Paul Oliver
+build-type: Simple
+maintainer: contact@pauloliver.dev
+name: hsm-status
+version: 0.1.0.0
+
+library
+ build-depends:
+ , base
+ , hsm-gpio
+ , hsm-log
+ , hsm-pwm
+
+ exposed-modules: Hsm.Status
+ ghc-options: -Wall -Wunused-packages
+ default-language: GHC2021
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..0fda386
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,9 @@
+packages:
+ - hsm-bin
+ - hsm-drive
+ - hsm-gpio
+ - hsm-log
+ - hsm-pwm
+ - hsm-readline
+ - hsm-status
+snapshot: lts-23.7
diff --git a/stack.yaml.lock b/stack.yaml.lock
new file mode 100644
index 0000000..6ce598a
--- /dev/null
+++ b/stack.yaml.lock
@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+# https://docs.haskellstack.org/en/stable/topics/lock_files
+
+packages: []
+snapshots:
+- completed:
+ sha256: 4ef79c30b9efcf07335cb3de532983a7ac4c5a4180bc17f6212a86b09ce2ff75
+ size: 680777
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/7.yaml
+ original: lts-23.7
diff --git a/sysconf/98-gpiod.rules b/sysconf/98-gpiod.rules
new file mode 100644
index 0000000..01a05ed
--- /dev/null
+++ b/sysconf/98-gpiod.rules
@@ -0,0 +1,2 @@
+# This rule grants the `gpio` group access to GPIO devices.
+SUBSYSTEM=="gpio", KERNEL=="gpiochip*", GROUP="gpiod", MODE="0660"
diff --git a/sysconf/99-pwm.rules b/sysconf/99-pwm.rules
new file mode 100644
index 0000000..8407ebe
--- /dev/null
+++ b/sysconf/99-pwm.rules
@@ -0,0 +1,12 @@
+# This UDEV rule provides the `pwm` user group with access to PWM devices.
+# Note that UDEV operates asynchronously, so there may be a slight delay
+# between changes to the directory structure (e.g., when a new PWM channel is
+# added) and the corresponding permission updates. To ensure the rule has been
+# fully applied, you can use the command `udevadm settle` to wait for the UDEV
+# process to complete.
+SUBSYSTEM=="pwm*", PROGRAM="/bin/sh -c ' \
+ chown -R root:pwm /sys/class/pwm ; \
+ chmod -R 770 /sys/class/pwm ; \
+ chown -R root:pwm /sys/devices/platform/axi/1000120000.pcie/*.pwm/pwm/pwmchip* ; \
+ chmod -R 770 /sys/devices/platform/axi/1000120000.pcie/*.pwm/pwm/pwmchip* ; \
+'"
diff --git a/sysconf/config.txt b/sysconf/config.txt
new file mode 100644
index 0000000..4bd4f67
--- /dev/null
+++ b/sysconf/config.txt
@@ -0,0 +1,57 @@
+# For more options and information see:
+# https://www.raspberrypi.com/documentation/computers/config_txt.html
+
+# Some settings may impact device functionality. See link above for details
+
+initramfs initramfs-linux.img followkernel
+
+# Uncomment some or all of these to enable the optional hardware interfaces
+#dtparam=i2c_arm=on
+#dtparam=i2s=on
+#dtparam=spi=on
+
+# Additional overlays and parameters are documented
+# /boot/overlays/README
+
+# Automatically load overlays for detected cameras
+camera_auto_detect=1
+
+# Automatically load overlays for detected DSI displays
+display_auto_detect=1
+
+# Enable DRM VC4 V3D driver
+dtoverlay=vc4-kms-v3d
+max_framebuffers=2
+
+# Don't have the firmware create an initial video= setting in cmdline.txt.
+# Use the kernel's default instead.
+disable_fw_kms_setup=1
+
+# Disable compensation for displays with overscan
+disable_overscan=1
+
+# Uncomment if hdmi display is not detected and composite is being output
+#hdmi_force_hotplug=1
+
+# Uncomment if you want to disable wifi or bluetooth respectively
+#dtoverlay=disable-wifi
+#dtoverlay=disable-bt
+
+# Uncomment this to enable infrared communication.
+#dtoverlay=gpio-ir,gpio_pin=17
+#dtoverlay=gpio-ir-tx,gpio_pin=18
+
+# Run as fast as firmware / board allows
+arm_boost=1
+
+[cm4]
+# Enable host mode on the 2711 built-in XHCI USB controller.
+# This line should be removed if the legacy DWC2 controller is required
+# (e.g. for USB device mode) or if USB support is not required.
+otg_mode=1
+
+[cm5]
+dtoverlay=dwc2,dr_mode=host
+
+[all]
+dtoverlay=pwm-2chan
powered by cgit v1.2.1, back to main portfolio site