From 7d7fa4816a1744d860c74a45003eda6cd71ec42a Mon Sep 17 00:00:00 2001
From: Paul Oliver <contact@pauloliver.dev>
Date: Wed, 17 Dec 2025 02:26:07 +0000
Subject: Adds battery monitoring service via INA226/I2C

---
 hsm-i2c/Hsm/I2C.hs      | 111 ++++++++++++++++++++++++++++++++++++++++++++++++
 hsm-i2c/Hsm/I2C/FFI.hsc |  58 +++++++++++++++++++++++++
 2 files changed, 169 insertions(+)
 create mode 100644 hsm-i2c/Hsm/I2C.hs
 create mode 100644 hsm-i2c/Hsm/I2C/FFI.hsc

(limited to 'hsm-i2c/Hsm')

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
-- 
cgit v1.2.1