aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hsm-battery/Hsm/Battery.hs120
-rw-r--r--hsm-battery/Hsm/Battery/FFI.hsc58
-rw-r--r--hsm-battery/Test/Battery.hs25
-rw-r--r--hsm-battery/hsm-battery.cabal49
-rw-r--r--hsm-core/Hsm/Core/Show.hs9
-rw-r--r--hsm-core/hsm-core.cabal1
-rw-r--r--stack.yaml2
-rw-r--r--stack.yaml.lock7
8 files changed, 271 insertions, 0 deletions
diff --git a/hsm-battery/Hsm/Battery.hs b/hsm-battery/Hsm/Battery.hs
new file mode 100644
index 0000000..22b61fd
--- /dev/null
+++ b/hsm-battery/Hsm/Battery.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.Battery
+ ( Battery
+ , BatteryState (..)
+ , readBatteryState
+ , runBattery
+ )
+where
+
+import Control.Exception (throwIO)
+import Control.Monad (when)
+import Data.Bits ((.&.), (.>>.), (.|.))
+import Data.Vector.Storable (fromList, unsafeWith)
+import Data.Word (Word16, Word8, byteSwap16)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
+import Effectful.Exception (Exception, bracket)
+import Foreign.Marshal.Utils (new, with)
+import Foreign.Ptr (castPtr)
+import Foreign.Storable (peek)
+import Hsm.Battery.FFI (I2CMsg (..), I2CRdWrIoctlData (..), i2cMNoStart, i2cMRd, i2cRdWr, ioctl)
+import Hsm.Core.Show (showHex)
+import Hsm.Log (Log, Severity (Info, Trace), logMsg)
+import System.Posix.IO (OpenMode (ReadWrite), closeFd, defaultFileFlags, openFd)
+import System.Posix.Types (Fd)
+
+data Battery (a :: * -> *) (b :: *)
+
+type instance DispatchOf Battery = Static WithSideEffects
+
+newtype instance StaticRep Battery
+ = Battery Fd
+
+data BatteryState = BatteryState
+ { voltage :: Float
+ , current :: Float
+ , power :: Float
+ }
+ deriving Show
+
+data BatteryException
+ = IOCtlErrorReturnValue
+ deriving (Exception, Show)
+
+ina226Addr :: Word16
+ina226Addr = 0x40
+
+i2cWriteShort :: (Battery :> es, Log "battery" :> es) => Word8 -> Word16 -> Eff es ()
+i2cWriteShort command bytes = do
+ Battery fd <- getStaticRep
+ logMsg Trace $ "Sending I2C write command " <> showHex command <> " with data " <> showHex bytes
+ unsafeEff_ . unsafeWith commandVec $ \commandPtr ->
+ with (msgVec commandPtr) $ \msgPtr ->
+ with (ioVec msgPtr) $ \ioPtr -> do
+ res <- ioctl fd i2cRdWr ioPtr
+ when (res == (-1)) $ throwIO IOCtlErrorReturnValue
+ where
+ commandVec = fromList [command, fromIntegral $ (bytes .&. 0xff00) .>>. 8, fromIntegral $ bytes .&. 0xff]
+ msgVec = I2CMsg ina226Addr 0 3
+ ioVec msgPtr = I2CRdWrIoctlData msgPtr 1
+
+i2cReadShort :: (Battery :> es, Log "battery" :> es) => Word8 -> Eff es Word16
+i2cReadShort command = do
+ Battery fd <- getStaticRep
+ logMsg Trace $ "Sending I2C read command " <> showHex command
+ unsafeEff_ $ do
+ resPtr <- new 0
+ with command $ \commandPtr ->
+ unsafeWith (msgVec commandPtr resPtr) $ \msgPtr ->
+ with (ioVec msgPtr) $ \ioPtr -> do
+ res <- ioctl fd i2cRdWr ioPtr
+ when (res == (-1)) $ throwIO IOCtlErrorReturnValue
+ byteSwap16 <$> peek resPtr
+ where
+ i2cFlags = fromIntegral $ i2cMRd .|. i2cMNoStart
+ msgVec commandPtr resPtr = fromList [I2CMsg ina226Addr 0 1 commandPtr, I2CMsg ina226Addr i2cFlags 2 $ castPtr resPtr]
+ ioVec msgPtr = I2CRdWrIoctlData msgPtr 2
+
+readBatteryState :: (Battery :> es, Log "battery" :> es) => Eff es BatteryState
+readBatteryState = do
+ voltage <- (* 0.00125) . fromIntegral <$> i2cReadShort ina226BusVoltageReg
+ current <- (* 0.0005) . fromIntegral <$> i2cReadShort ina226CurrentReg
+ power <- (* 0.0125) . fromIntegral <$> i2cReadShort ina226PowerReg
+ return BatteryState{..}
+ where
+ ina226BusVoltageReg = 0x02
+ ina226PowerReg = 0x03
+ ina226CurrentReg = 0x04
+
+runBattery :: (IOE :> es, Log "battery" :> es) => Eff (Battery : es) a -> Eff es a
+runBattery action =
+ bracket openI2CDev closeI2CDev $ \fd ->
+ evalStaticRep (Battery fd) $ do
+ i2cWriteShort ina226CfgReg 0x8000 -- reset
+ i2cWriteShort ina226CfgReg 0x4527 -- average over 16 samples
+ i2cWriteShort ina226CalReg 1024 -- 1A, 0.1 Ohm resistor
+ manId <- i2cReadShort ina226ManufacturerId
+ dieId <- i2cReadShort ina226DieId
+ cfgReg <- i2cReadShort ina226CfgReg
+ logMsg Info $ "INA226 manufacturer ID: " <> showHex manId
+ logMsg Info $ "INA226 die ID: " <> showHex dieId
+ logMsg Info $ "INA226 configuration register: " <> showHex cfgReg
+ action
+ where
+ devPath = "/dev/i2c-0"
+ openI2CDev = do
+ logMsg Info $ "Opening I2C INA226 device at " <> devPath
+ fd <- liftIO $ openFd devPath ReadWrite defaultFileFlags
+ logMsg Info $ "I2C INA226 device opened with FD: " <> show fd
+ return fd
+ closeI2CDev fd = do
+ logMsg Info $ "Closing I2C INA226 device at " <> devPath <> " with FD: " <> show fd
+ liftIO $ closeFd fd
+ ina226CfgReg = 0x00
+ ina226CalReg = 0x05
+ ina226ManufacturerId = 0xfe
+ ina226DieId = 0xff
diff --git a/hsm-battery/Hsm/Battery/FFI.hsc b/hsm-battery/Hsm/Battery/FFI.hsc
new file mode 100644
index 0000000..3ccb5c1
--- /dev/null
+++ b/hsm-battery/Hsm/Battery/FFI.hsc
@@ -0,0 +1,58 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Hsm.Battery.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-battery/Test/Battery.hs b/hsm-battery/Test/Battery.hs
new file mode 100644
index 0000000..caf24a6
--- /dev/null
+++ b/hsm-battery/Test/Battery.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (forever)
+import Data.Function ((&))
+import Effectful (liftIO, runEff)
+import Hsm.Battery (readBatteryState, runBattery)
+import Hsm.Core.App (bootstrapApp)
+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 = '["battery"]
+
+$(makeLoggerOptionParser @Logs "Options" "parser" 'Info)
+
+main :: IO ()
+main =
+ bootstrapApp parser "Launch Battery Monitoring Test Application" $ \opts ->
+ (forever $ liftIO (threadDelay 1000000) >> readBatteryState >>= logMsg Info . show)
+ & runBattery
+ & runLogsOpt @Options @Logs opts
+ & runEff
diff --git a/hsm-battery/hsm-battery.cabal b/hsm-battery/hsm-battery.cabal
new file mode 100644
index 0000000..3614868
--- /dev/null
+++ b/hsm-battery/hsm-battery.cabal
@@ -0,0 +1,49 @@
+cabal-version: 3.8
+author: Paul Oliver <contact@pauloliver.dev>
+name: hsm-battery
+version: 0.1.0.0
+
+library
+ build-depends:
+ , base
+ , c-storable-deriving
+ , effectful-core
+ , effectful-plugin
+ , hsm-core
+ , hsm-log
+ , unix
+ , vector
+
+ default-language: GHC2024
+ exposed-modules: Hsm.Battery
+ ghc-options:
+ -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages
+ -fplugin=Effectful.Plugin
+
+ other-modules: Hsm.Battery.FFI
+
+executable test-battery
+ build-depends:
+ , base
+ , c-storable-deriving
+ , effectful-core
+ , effectful-plugin
+ , hsm-battery
+ , hsm-core
+ , hsm-log
+ , optparse-applicative
+ , unix
+ , vector
+
+ 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/Battery.hs
+ other-modules:
+ Hsm.Battery
+ Hsm.Battery.FFI
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/stack.yaml b/stack.yaml
index cc0edae..37f2d81 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,7 +1,9 @@
extra-deps:
+ - c-storable-deriving-0.1.3
- resourcet-effectful-1.0.1.0
- typelits-printf-0.3.0.0
packages:
+ - hsm-battery
- hsm-cam
- hsm-core
- hsm-drive
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 4f4dfc4..407064b 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
powered by cgit v1.2.1, back to main portfolio site