aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hsm-core/Hsm/Core/Show.hs9
-rw-r--r--hsm-core/hsm-core.cabal1
-rw-r--r--hsm-i2c/Hsm/I2C.hs111
-rw-r--r--hsm-i2c/Hsm/I2C/FFI.hsc58
-rw-r--r--hsm-i2c/hsm-i2c.cabal24
-rw-r--r--hsm-ina226/Hsm/INA226.hs114
-rw-r--r--hsm-ina226/Test/INA226.hs27
-rw-r--r--hsm-ina226/hsm-ina226.cabal40
-rw-r--r--stack.yaml5
-rw-r--r--stack.yaml.lock15
10 files changed, 399 insertions, 5 deletions
diff --git a/hsm-core/Hsm/Core/Show.hs b/hsm-core/Hsm/Core/Show.hs
new file mode 100644
index 0000000..601ea03
--- /dev/null
+++ b/hsm-core/Hsm/Core/Show.hs
@@ -0,0 +1,9 @@
+-- Defines some convenience printing functions
+module Hsm.Core.Show
+ ( showHex
+ ) where
+
+import Numeric qualified as N (showHex)
+
+showHex :: Integral a => a -> String
+showHex v = "0x" <> N.showHex v ""
diff --git a/hsm-core/hsm-core.cabal b/hsm-core/hsm-core.cabal
index 6a0efff..f9f5657 100644
--- a/hsm-core/hsm-core.cabal
+++ b/hsm-core/hsm-core.cabal
@@ -18,5 +18,6 @@ library
Hsm.Core.App
Hsm.Core.Bracket
Hsm.Core.Serial
+ Hsm.Core.Show
ghc-options: -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
diff --git a/hsm-i2c/Hsm/I2C.hs b/hsm-i2c/Hsm/I2C.hs
new file mode 100644
index 0000000..6a7956c
--- /dev/null
+++ b/hsm-i2c/Hsm/I2C.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.I2C
+ ( I2C
+ , writeWord16
+ , readWord16
+ , readInt16
+ , runI2C
+ )
+where
+
+import Control.Monad (void)
+import Control.Monad.Trans.Cont (cont, evalCont)
+import Data.Bits ((.&.), (.>>.), (.|.))
+import Data.Int (Int16)
+import Data.Proxy (Proxy (Proxy))
+import Data.Vector.Storable (fromList, unsafeWith)
+import Data.Word (Word16, Word8, byteSwap16)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
+import Effectful.Exception (bracket)
+import Foreign.Marshal.Utils (with)
+import Foreign.Ptr (castPtr)
+import Foreign.Storable (peek)
+import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal)
+import Hsm.Core.Show (showHex)
+import Hsm.I2C.FFI (I2CMsg (I2CMsg), I2CRdWrIoctlData (I2CRdWrIoctlData), i2cMNoStart, i2cMRd, i2cRdWr, ioctl)
+import Hsm.Log (Log, Severity (Info, Trace), logMsg)
+import System.Posix.IO (OpenMode (ReadWrite), closeFd, defaultFileFlags, openFd)
+import System.Posix.Types (Fd)
+
+-- I2C communication effect for a specific physical device
+-- Each effect instance corresponds to one I2C device, uniquely identified by:
+-- - `d` - Device path (e.g., '/dev/i2c-0')
+-- - `x` - 7-bit device address (e.g., '0x40')
+data I2C (d :: Symbol) (x :: Nat) (a :: * -> *) (b :: *)
+
+type instance DispatchOf (I2C d x) = Static WithSideEffects
+
+newtype instance StaticRep (I2C d x)
+ = I2C Fd
+
+path
+ :: forall d
+ . KnownSymbol d
+ => String
+path = symbolVal $ Proxy @d
+
+addr
+ :: forall x
+ . KnownNat x
+ => Word16
+addr = fromIntegral . natVal $ Proxy @x
+
+writeWord16
+ :: forall d x es
+ . (I2C d x :> es, KnownNat x, KnownSymbol d, Log "i2c" :> es)
+ => Word8
+ -> Word16
+ -> Eff es ()
+writeWord16 command bytes = do
+ I2C fd <- getStaticRep
+ logMsg Trace $ "Sending write command " <> hexCommand <> " with data " <> hexBytes <> " to device " <> path @d
+ unsafeEff_ . evalCont $ do
+ commandPtr <- cont . unsafeWith $ fromList [command, byte0, byte1]
+ msgPtr <- cont . with $ I2CMsg (addr @x) 0 3 commandPtr
+ ioPtr <- cont . with $ I2CRdWrIoctlData msgPtr 1
+ return . void $ ioctl fd i2cRdWr ioPtr
+ where
+ hexCommand = showHex command
+ hexBytes = showHex bytes
+ byte0 = fromIntegral $ (bytes .&. 0xff00) .>>. 8
+ byte1 = fromIntegral $ bytes .&. 0xff
+
+readWord16
+ :: forall d x es
+ . (I2C d x :> es, KnownNat x, KnownSymbol d, Log "i2c" :> es)
+ => Word8
+ -> Eff es Word16
+readWord16 command = do
+ I2C fd <- getStaticRep
+ logMsg Trace $ "Sending I2C read command " <> hexCommand <> " to device " <> path @d
+ unsafeEff_ . evalCont $ do
+ commandPtr <- cont $ with command
+ resPtr <- cont $ with 0
+ msgPtr <- cont . unsafeWith $ fromList [I2CMsg (addr @x) 0 1 commandPtr, I2CMsg (addr @x) i2cFlags 2 $ castPtr resPtr]
+ ioPtr <- cont . with $ I2CRdWrIoctlData msgPtr 2
+ return $ ioctl fd i2cRdWr ioPtr >> byteSwap16 <$> peek resPtr
+ where
+ hexCommand = showHex command
+ i2cFlags = fromIntegral $ i2cMRd .|. i2cMNoStart
+
+readInt16 :: (I2C d x :> es, KnownNat x, KnownSymbol d, Log "i2c" :> es) => Word8 -> Eff es Int16
+readInt16 = fmap fromIntegral . readWord16
+
+runI2C
+ :: forall d x es a
+ . (IOE :> es, KnownNat x, KnownSymbol d, Log "i2c" :> es)
+ => Eff (I2C d x : es) a
+ -> Eff es a
+runI2C action = bracket openI2CDev closeI2CDev $ \fd -> evalStaticRep (I2C fd) action
+ where
+ openI2CDev = do
+ logMsg Info $ "Opening device at " <> path @d
+ fd <- unsafeEff_ $ openFd (path @d) ReadWrite defaultFileFlags
+ logMsg Info $ "I2C device opened with FD: " <> show fd
+ return fd
+ closeI2CDev fd = do
+ logMsg Info $ "Closing device at " <> path @d <> " with FD: " <> show fd
+ unsafeEff_ $ closeFd fd
diff --git a/hsm-i2c/Hsm/I2C/FFI.hsc b/hsm-i2c/Hsm/I2C/FFI.hsc
new file mode 100644
index 0000000..459b45c
--- /dev/null
+++ b/hsm-i2c/Hsm/I2C/FFI.hsc
@@ -0,0 +1,58 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Hsm.I2C.FFI
+ ( I2CMsg (..)
+ , I2CRdWrIoctlData (..)
+ , i2cRdWr
+ , i2cMRd
+ , i2cMNoStart
+ , ioctl
+ )
+where
+
+import Data.Word (Word16, Word32, Word8)
+import Foreign.C.Types (CInt (CInt))
+import Foreign.CStorable (CStorable, cAlignment, cPeek, cPoke, cSizeOf)
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (Storable (..))
+import GHC.Generics (Generic)
+import System.Posix.Types (Fd (Fd))
+
+data I2CMsg = I2CMsg
+ { addr :: Word16
+ , flags :: Word16
+ , len :: Word16
+ , buf :: Ptr Word8
+ }
+ deriving (CStorable, Generic, Show)
+
+instance Storable I2CMsg where
+ sizeOf = cSizeOf
+ alignment = cAlignment
+ poke = cPoke
+ peek = cPeek
+
+data I2CRdWrIoctlData = I2CRdWrIoctlData
+ { msgs :: Ptr I2CMsg
+ , nmsgs :: Word32
+ }
+ deriving (CStorable, Generic, Show)
+
+instance Storable I2CRdWrIoctlData where
+ sizeOf = cSizeOf
+ alignment = cAlignment
+ poke = cPoke
+ peek = cPeek
+
+foreign import capi safe "linux/i2c-dev.h value I2C_RDWR"
+ i2cRdWr :: Int
+
+foreign import capi safe "linux/i2c.h value I2C_M_RD"
+ i2cMRd :: Int
+
+foreign import capi safe "linux/i2c.h value I2C_M_NOSTART"
+ i2cMNoStart :: Int
+
+foreign import capi safe "sys/ioctl.h"
+ ioctl :: Fd -> Int -> Ptr a -> IO Int
diff --git a/hsm-i2c/hsm-i2c.cabal b/hsm-i2c/hsm-i2c.cabal
new file mode 100644
index 0000000..2518fb2
--- /dev/null
+++ b/hsm-i2c/hsm-i2c.cabal
@@ -0,0 +1,24 @@
+cabal-version: 3.8
+author: Paul Oliver <contact@pauloliver.dev>
+name: hsm-i2c
+version: 0.1.0.0
+
+library
+ build-depends:
+ , base
+ , c-storable-deriving
+ , effectful-core
+ , effectful-plugin
+ , hsm-core
+ , hsm-log
+ , transformers
+ , unix
+ , vector
+
+ default-language: GHC2024
+ exposed-modules: Hsm.I2C
+ ghc-options:
+ -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
+ -fplugin=Effectful.Plugin
+
+ other-modules: Hsm.I2C.FFI
diff --git a/hsm-ina226/Hsm/INA226.hs b/hsm-ina226/Hsm/INA226.hs
new file mode 100644
index 0000000..8862689
--- /dev/null
+++ b/hsm-ina226/Hsm/INA226.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.INA226
+ ( INA226
+ , INA226Reading (..)
+ , INA226Path
+ , INA226Addr
+ , readINA226State
+ , runINA226
+ )
+where
+
+import Data.Word (Word16, Word8)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep)
+import Hsm.Core.Show (showHex)
+import Hsm.I2C (I2C, readInt16, readWord16, writeWord16)
+import Hsm.Log (Logs, Severity (Info, Trace), logMsg)
+
+data INA226 (a :: * -> *) (b :: *)
+
+type instance DispatchOf INA226 = Static WithSideEffects
+
+newtype instance StaticRep INA226
+ = INA226 ()
+
+data INA226Reading = INA226Reading
+ { voltage :: Float
+ , current :: Float
+ , power :: Float
+ }
+ deriving Show
+
+-- INA226 I2C device path and address
+type INA226Path = "/dev/i2c-0"
+
+type INA226Addr = 64
+
+-- INA226 registers
+configurationReg :: Word8
+configurationReg = 0x00
+
+busVoltageReg :: Word8
+busVoltageReg = 0x02
+
+powerReg :: Word8
+powerReg = 0x03
+
+currentReg :: Word8
+currentReg = 0x04
+
+calibratonReg :: Word8
+calibratonReg = 0x05
+
+manufacturerIdReg :: Word8
+manufacturerIdReg = 0xfe
+
+dieIdReg :: Word8
+dieIdReg = 0xff
+
+-- Configuration and calibration constants
+-- For reference, data sheet can be found here:
+-- https://www.ti.com/lit/ds/symlink/ina226.pdf
+reset :: Word16
+reset = 0b1000000000000000
+
+-- Average values over 16 samples
+-- Use a 1.1ms conversion time for bus voltage and shunt voltage readings
+-- Use continuous shunt and bus voltage operating mode
+configuration :: Word16
+configuration = 0b0000010100100111
+
+-- Decide LSB for current readings based on expected max current:
+-- CurrentLSB == max_expected_current / 2^15 == 5A / 2^15 == 0.2mA/bit (rounded up)
+currentLSB :: Float
+currentLSB = 0.0002
+
+-- PowerLSB = CurrentLSB * 25
+powerLSB :: Float
+powerLSB = currentLSB * 25
+
+-- Calibration == 0.00512 / (CurrentLSB * Rshunt) == 0.00512 / (0.0002 * 0.002) == 12800
+calibration :: Word16
+calibration = 12800
+
+-- Voltage LSB is fixed
+busVoltageLSB :: Float
+busVoltageLSB = 0.00125
+
+-- Read INA226 voltage/current/power registers
+readINA226State :: (I2C INA226Path INA226Addr :> es, INA226 :> es, Logs '["i2c", "ina226"] es) => Eff es INA226Reading
+readINA226State = do
+ logMsg @"ina226" Trace "Reading INA226 state registers"
+ voltage <- (* busVoltageLSB) . fromIntegral <$> readWord16 busVoltageReg
+ current <- (* currentLSB) . fromIntegral <$> readInt16 currentReg
+ power <- (* powerLSB) . fromIntegral <$> readInt16 powerReg
+ return INA226Reading{..}
+
+runINA226
+ :: (I2C INA226Path INA226Addr :> es, IOE :> es, Logs '["i2c", "ina226"] es) => Eff (INA226 : es) a -> Eff es a
+runINA226 action = do
+ -- Prepare chip
+ writeWord16 configurationReg reset
+ writeWord16 configurationReg configuration
+ writeWord16 calibratonReg calibration
+ -- Print some stats to the user
+ manId <- readWord16 manufacturerIdReg
+ dieId <- readWord16 dieIdReg
+ cfgReg <- readWord16 configurationReg
+ logMsg @"ina226" Info $ "INA226 manufacturer ID: " <> showHex manId
+ logMsg @"ina226" Info $ "INA226 die ID: " <> showHex dieId
+ logMsg @"ina226" Info $ "INA226 configuration register: " <> showHex cfgReg
+ evalStaticRep (INA226 ()) action
diff --git a/hsm-ina226/Test/INA226.hs b/hsm-ina226/Test/INA226.hs
new file mode 100644
index 0000000..71f8f45
--- /dev/null
+++ b/hsm-ina226/Test/INA226.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (forever)
+import Data.Function ((&))
+import Effectful (liftIO, runEff)
+import Hsm.Core.App (bootstrapApp)
+import Hsm.I2C (runI2C)
+import Hsm.INA226 (readINA226State, runINA226)
+import Hsm.Log (Severity (Info), logMsg, runLogsOpt)
+import Hsm.Log.Options (makeLoggerOptionParser)
+-- Import full module for cleaner `-ddump-splices` output
+-- Avoids package/module qualifiers in generated code
+import Options.Applicative
+
+type Logs = '["i2c", "ina226"]
+
+$(makeLoggerOptionParser @Logs "Options" "parser" 'Info)
+
+main :: IO ()
+main =
+ bootstrapApp parser "Launch INA226 Monitoring Test Application" $ \opts ->
+ forever (liftIO (threadDelay 1000000) >> readINA226State >>= logMsg @"ina226" Info . show)
+ & runINA226
+ & runI2C
+ & runLogsOpt @Options @Logs opts
+ & runEff
diff --git a/hsm-ina226/hsm-ina226.cabal b/hsm-ina226/hsm-ina226.cabal
new file mode 100644
index 0000000..3b25b29
--- /dev/null
+++ b/hsm-ina226/hsm-ina226.cabal
@@ -0,0 +1,40 @@
+cabal-version: 3.8
+author: Paul Oliver <contact@pauloliver.dev>
+name: hsm-ina226
+version: 0.1.0.0
+
+library
+ build-depends:
+ , base
+ , effectful-core
+ , effectful-plugin
+ , hsm-core
+ , hsm-i2c
+ , hsm-log
+
+ default-language: GHC2024
+ exposed-modules: Hsm.INA226
+ ghc-options:
+ -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
+ -fplugin=Effectful.Plugin
+
+executable test-ina226
+ build-depends:
+ , base
+ , effectful-core
+ , effectful-plugin
+ , hsm-core
+ , hsm-i2c
+ , hsm-log
+ , optparse-applicative
+
+ default-language: GHC2024
+ ghc-options:
+ -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
+ -Wno-unused-imports -fplugin=Effectful.Plugin
+
+ if !arch(x86_64)
+ ghc-options: -optl=-mno-fix-cortex-a53-835769
+
+ main-is: Test/INA226.hs
+ other-modules: Hsm.INA226
diff --git a/stack.yaml b/stack.yaml
index cc0edae..0f0cec2 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,5 @@
extra-deps:
+ - c-storable-deriving-0.1.3
- resourcet-effectful-1.0.1.0
- typelits-printf-0.3.0.0
packages:
@@ -6,8 +7,10 @@ packages:
- hsm-core
- hsm-drive
- hsm-gpio
+ - hsm-i2c
+ - hsm-ina226
- hsm-log
- hsm-pwm
- hsm-repl
- hsm-web
-resolver: lts-24.23
+resolver: lts-24.24
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 4f4dfc4..74cd02d 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -5,6 +5,13 @@
packages:
- completed:
+ hackage: c-storable-deriving-0.1.3@sha256:510aa8423d6b3df57a39365569195ddc5bd4b04b0ff58ba1345c1f309ae6f89e,1030
+ pantry-tree:
+ sha256: 17a631450a907af3253c3aa95414239b1adea9c5d9777705d6beab712cdf61a6
+ size: 369
+ original:
+ hackage: c-storable-deriving-0.1.3
+- completed:
hackage: resourcet-effectful-1.0.1.0@sha256:13f94c9832d0d1573abbabcddc5c3aa3c341973d1d442445795593e355e7803e,2115
pantry-tree:
sha256: ef0db7bdeca5df1e722958cf5c8f3205ed5bf92b111e0fbc5d1a3c592d1c210e
@@ -20,7 +27,7 @@ packages:
hackage: typelits-printf-0.3.0.0
snapshots:
- completed:
- sha256: dc2c118f708ee595ccad08b5be08ed276659b0c22ba7c8ba1ef25a49af318c50
- size: 726332
- url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/23.yaml
- original: lts-24.23
+ sha256: 4bc8e0388916c4000645c068dff642482d6ed1b68b747c2d4d444857979963e0
+ size: 726334
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/24.yaml
+ original: lts-24.24
powered by cgit v1.2.1, back to main portfolio site