aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hsm-cam/Hsm/Cam.hs24
-rw-r--r--hsm-cam/Hsm/Cam/FFI.hs64
-rw-r--r--hsm-cam/Hsm/Cam/FFI.hsc82
-rw-r--r--hsm-cam/Test/Cam.hs11
-rw-r--r--hsm-core/Hsm/Core/App.hs23
-rw-r--r--hsm-core/Hsm/Core/Bracket.hs5
-rw-r--r--hsm-core/Hsm/Core/Serial.hs21
-rw-r--r--hsm-core/hsm-core.cabal2
-rw-r--r--hsm-gpio/Hsm/GPIO.hs17
-rw-r--r--hsm-gpio/Hsm/GPIO/FFI.hs95
-rw-r--r--hsm-gpio/Hsm/GPIO/FFI.hsc116
-rw-r--r--hsm-log/Hsm/Log.hs58
-rw-r--r--hsm-log/Hsm/Log/Options.hs38
-rw-r--r--hsm-pwm/Hsm/PWM.hs15
-rw-r--r--hsm-repl/Hsm/Repl.hs37
-rw-r--r--hsm-repl/Test/Repl.hs5
-rw-r--r--hsm-web/Hsm/Web.hs26
-rw-r--r--hsm-web/Main.hs10
18 files changed, 379 insertions, 270 deletions
diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs
index e5b30c2..d1f9cd2 100644
--- a/hsm-cam/Hsm/Cam.hs
+++ b/hsm-cam/Hsm/Cam.hs
@@ -6,9 +6,10 @@ module Hsm.Cam
( Cam
, capturePng
, runCam
- ) where
+ )
+where
-import Codec.Picture (Image(Image), encodePng)
+import Codec.Picture (Image (Image), encodePng)
import Codec.Picture.Types (PixelRGB8)
import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (mask_)
@@ -19,11 +20,11 @@ import Data.ByteString.Lazy (ByteString)
import Data.List ((!?))
import Data.Primitive.Ptr (readOffPtr)
import Data.Vector.Storable (generateM)
-import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
-import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket, bracket_)
import Foreign.C.String (peekCString)
-import Foreign.C.Types (CSize(CSize))
+import Foreign.C.Types (CSize (CSize))
import Foreign.Ptr (Ptr, castPtr, freeHaskellFunPtr, nullPtr)
import Hsm.Cam.FFI
( acquireCamera
@@ -45,11 +46,11 @@ import Hsm.Cam.FFI
, stopCameraManager
)
import Hsm.Core.Bracket (bracketConst, bracketLiftIO_)
-import Hsm.Log (Log, Severity(Attention, Info, Trace), getLevel, logMsg, makeLoggerIO)
+import Hsm.Log (Log, Severity (Attention, Info, Trace), getLevel, logMsg, makeLoggerIO)
import MMAP (mapShared, mkMmapFlags, mmap, munmap, protRead)
import System.Directory (doesFileExist, removeFile)
import System.Environment (setEnv)
-import System.IO (IOMode(ReadWriteMode), hGetLine, withFile)
+import System.IO (IOMode (ReadWriteMode), hGetLine, withFile)
import System.Posix.Files (createNamedPipe, ownerReadMode, ownerWriteMode)
import Text.Read (readMaybe)
@@ -62,8 +63,8 @@ data Rep = Rep
, dmaBuffer :: Ptr ()
}
-newtype instance StaticRep Cam =
- Cam Rep
+newtype instance StaticRep Cam
+ = Cam Rep
-- RGB888 configuration for ov5647 sensor (Raspberry Pi Camera Module)
-- The following constants must be updated if either:
@@ -80,7 +81,7 @@ frameBufferLength = frameStride * frameHeight + 3072
capturePng :: (Log "cam" :> es, Cam :> es) => Eff es ByteString
capturePng = do
- Cam Rep {..} <- getStaticRep
+ Cam Rep{..} <- getStaticRep
logMsg Trace "Requesting frame"
unsafeEff_ . mask_ $ requestFrame >> takeMVar requestCallbackMVar
logMsg Trace "Processing frame data"
@@ -130,7 +131,8 @@ runCam action = do
. bracketLiftIO_ allocateFrameBuffer freeFrameBuffer
. bracketLiftIO_ startCamera stopCamera
. bracketLiftIO_ createRequest (return ())
- . bracket mapDmaBuffer unmapDmaBuffer $ \dmaBuffer -> evalStaticRep (Cam Rep {..}) action
+ . bracket mapDmaBuffer unmapDmaBuffer
+ $ \dmaBuffer -> evalStaticRep (Cam Rep{..}) action
where
loggerAlloc = do
logMsg @"cam" Info "Registering FFI logger"
diff --git a/hsm-cam/Hsm/Cam/FFI.hs b/hsm-cam/Hsm/Cam/FFI.hs
deleted file mode 100644
index 50acf10..0000000
--- a/hsm-cam/Hsm/Cam/FFI.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-{-# LANGUAGE CApiFFI #-}
-
-module Hsm.Cam.FFI
- ( frameWidth
- , frameHeight
- , makeLogger
- , registerLogger
- , makeRequestCallback
- , registerRequestCallback
- , startCameraManager
- , stopCameraManager
- , acquireCamera
- , releaseCamera
- , allocateFrameBuffer
- , freeFrameBuffer
- , startCamera
- , stopCamera
- , createRequest
- , getDmaBufferFd
- , requestFrame
- ) where
-
-import Foreign.C.String (CString)
-import Foreign.C.Types (CInt(CInt))
-import Foreign.Ptr (FunPtr)
-import System.Posix.Types (Fd(Fd))
-
-type Logger = Int -> CString -> IO ()
-
-type RequestCallback = IO ()
-
-foreign import capi safe "Cam.hpp value FRAME_WIDTH" frameWidth :: Int
-
-foreign import capi safe "Cam.hpp value FRAME_HEIGHT" frameHeight :: Int
-
-foreign import ccall safe "wrapper" makeLogger :: Logger -> IO (FunPtr Logger)
-
-foreign import capi safe "Cam.hpp register_logger" registerLogger :: FunPtr Logger -> IO ()
-
-foreign import ccall safe "wrapper" makeRequestCallback :: RequestCallback -> IO (FunPtr RequestCallback)
-
-foreign import capi safe "Cam.hpp register_request_callback" registerRequestCallback :: FunPtr RequestCallback -> IO ()
-
-foreign import capi safe "Cam.hpp start_camera_manager" startCameraManager :: IO ()
-
-foreign import capi safe "Cam.hpp stop_camera_manager" stopCameraManager :: IO ()
-
-foreign import capi safe "Cam.hpp acquire_camera" acquireCamera :: IO ()
-
-foreign import capi safe "Cam.hpp release_camera" releaseCamera :: IO ()
-
-foreign import capi safe "Cam.hpp allocate_frame_buffer" allocateFrameBuffer :: IO ()
-
-foreign import capi safe "Cam.hpp free_frame_buffer" freeFrameBuffer :: IO ()
-
-foreign import capi safe "Cam.hpp start_camera" startCamera :: IO ()
-
-foreign import capi safe "Cam.hpp stop_camera" stopCamera :: IO ()
-
-foreign import capi safe "Cam.hpp create_request" createRequest :: IO ()
-
-foreign import capi safe "Cam.hpp get_dma_buffer_fd" getDmaBufferFd :: IO Fd
-
-foreign import capi safe "Cam.hpp request_frame" requestFrame :: IO ()
diff --git a/hsm-cam/Hsm/Cam/FFI.hsc b/hsm-cam/Hsm/Cam/FFI.hsc
new file mode 100644
index 0000000..6c5dd3d
--- /dev/null
+++ b/hsm-cam/Hsm/Cam/FFI.hsc
@@ -0,0 +1,82 @@
+{-# LANGUAGE CApiFFI #-}
+
+module Hsm.Cam.FFI
+ ( frameWidth
+ , frameHeight
+ , makeLogger
+ , registerLogger
+ , makeRequestCallback
+ , registerRequestCallback
+ , startCameraManager
+ , stopCameraManager
+ , acquireCamera
+ , releaseCamera
+ , allocateFrameBuffer
+ , freeFrameBuffer
+ , startCamera
+ , stopCamera
+ , createRequest
+ , getDmaBufferFd
+ , requestFrame
+ )
+where
+
+import Foreign.C.String (CString)
+import Foreign.C.Types (CInt (CInt))
+import Foreign.Ptr (FunPtr)
+import System.Posix.Types (Fd (Fd))
+
+type Logger = Int -> CString -> IO ()
+
+type RequestCallback = IO ()
+
+foreign import capi safe "Cam.hpp value FRAME_WIDTH"
+ frameWidth :: Int
+
+foreign import capi safe "Cam.hpp value FRAME_HEIGHT"
+ frameHeight :: Int
+
+foreign import ccall safe "wrapper"
+ makeLogger :: Logger -> IO (FunPtr Logger)
+
+foreign import capi safe "Cam.hpp register_logger"
+ registerLogger :: FunPtr Logger -> IO ()
+
+foreign import ccall safe "wrapper"
+ makeRequestCallback :: RequestCallback -> IO (FunPtr RequestCallback)
+
+foreign import capi safe "Cam.hpp register_request_callback"
+ registerRequestCallback :: FunPtr RequestCallback -> IO ()
+
+foreign import capi safe "Cam.hpp start_camera_manager"
+ startCameraManager :: IO ()
+
+foreign import capi safe "Cam.hpp stop_camera_manager"
+ stopCameraManager :: IO ()
+
+foreign import capi safe "Cam.hpp acquire_camera"
+ acquireCamera :: IO ()
+
+foreign import capi safe "Cam.hpp release_camera"
+ releaseCamera :: IO ()
+
+foreign import capi safe "Cam.hpp allocate_frame_buffer"
+ allocateFrameBuffer :: IO ()
+
+foreign import capi safe "Cam.hpp free_frame_buffer"
+ freeFrameBuffer :: IO ()
+
+foreign import capi safe "Cam.hpp start_camera"
+ startCamera :: IO ()
+
+foreign import capi safe "Cam.hpp stop_camera"
+ stopCamera :: IO ()
+
+foreign import capi safe "Cam.hpp create_request"
+ createRequest :: IO ()
+
+foreign import capi safe "Cam.hpp get_dma_buffer_fd"
+ getDmaBufferFd :: IO Fd
+
+foreign import capi safe "Cam.hpp request_frame"
+ requestFrame :: IO ()
diff --git a/hsm-cam/Test/Cam.hs b/hsm-cam/Test/Cam.hs
index 5c8daf5..94d3b73 100644
--- a/hsm-cam/Test/Cam.hs
+++ b/hsm-cam/Test/Cam.hs
@@ -1,12 +1,17 @@
import Control.Monad (forM_)
+import Data.Function ((&))
import Effectful (runEff)
import Effectful.FileSystem (runFileSystem)
import Effectful.FileSystem.IO.ByteString.Lazy (writeFile)
import Hsm.Cam (capturePng, runCam)
-import Hsm.Log (Severity(Info, Trace), runLog)
+import Hsm.Log (Severity (Info, Trace), runLog)
import Prelude hiding (writeFile)
main :: IO ()
main =
- runEff . runFileSystem . runLog @"cam" Trace . runLog @"libcamera" Info . runCam . forM_ [0 .. 31] $ \index ->
- capturePng >>= writeFile ("/tmp/hsm-cam-test" <> show @Int index <> ".png")
+ forM_ [0 .. 31] (\index -> capturePng >>= writeFile ("/tmp/hsm-cam-test" <> show @Int index <> ".png"))
+ & runCam
+ & runLog @"cam" Trace
+ & runLog @"libcamera" Info
+ & runFileSystem
+ & runEff
diff --git a/hsm-core/Hsm/Core/App.hs b/hsm-core/Hsm/Core/App.hs
index 12849d4..88dabb2 100644
--- a/hsm-core/Hsm/Core/App.hs
+++ b/hsm-core/Hsm/Core/App.hs
@@ -1,9 +1,20 @@
+-- Provides combinators for bootstrapping applications with:
+-- - Automated command-line parsing
+-- - Help text generation
module Hsm.Core.App
- ( runApp
- ) where
+ ( bootstrapApp
+ , bootstrapAppNoEcho
+ )
+where
-import Effectful (Eff, IOE, runEff)
-import Options.Applicative (Parser, (<**>), execParser, fullDesc, helper, info, progDesc)
+import Data.Composition ((.:.))
+import Options.Applicative (Parser, execParser, fullDesc, helper, info, progDesc, (<**>))
+import System.IO.Echo (withoutInputEcho)
-runApp :: Parser o -> String -> (o -> Eff '[ IOE] a) -> IO a
-runApp parser desc app = execParser (info (parser <**> helper) $ fullDesc <> progDesc desc) >>= runEff . app
+-- Launches a console application with input echo enabled
+bootstrapApp :: Parser o -> String -> (o -> IO a) -> IO a
+bootstrapApp parser desc app = execParser (info (parser <**> helper) $ fullDesc <> progDesc desc) >>= app
+
+-- Launches an application with hidden input echo
+bootstrapAppNoEcho :: Parser o -> String -> (o -> IO a) -> IO a
+bootstrapAppNoEcho = withoutInputEcho .:. bootstrapApp
diff --git a/hsm-core/Hsm/Core/Bracket.hs b/hsm-core/Hsm/Core/Bracket.hs
index f666d86..92428de 100644
--- a/hsm-core/Hsm/Core/Bracket.hs
+++ b/hsm-core/Hsm/Core/Bracket.hs
@@ -4,10 +4,11 @@ module Hsm.Core.Bracket
( bracketConst
, bracketCont
, bracketLiftIO_
- ) where
+ )
+where
import Control.Monad.Trans.Cont (Cont, cont)
-import Effectful (Eff, IOE, (:>), liftIO)
+import Effectful (Eff, IOE, liftIO, (:>))
import Effectful.Exception (bracket, bracket_)
-- Ignores allocated resource in the action
diff --git a/hsm-core/Hsm/Core/Serial.hs b/hsm-core/Hsm/Core/Serial.hs
index 9a4d2b7..7c607ff 100644
--- a/hsm-core/Hsm/Core/Serial.hs
+++ b/hsm-core/Hsm/Core/Serial.hs
@@ -2,21 +2,22 @@
module Hsm.Core.Serial
( makeSerial
- ) where
+ )
+where
import GHC.Num (integerFromInt)
import Language.Haskell.TH
- ( Body(NormalB)
- , Clause(Clause)
- , Con(NormalC)
- , Dec(DataD, FunD, SigD)
- , DerivClause(DerivClause)
- , Exp(LitE)
- , Lit(IntegerL)
+ ( Body (NormalB)
+ , Clause (Clause)
+ , Con (NormalC)
+ , Dec (DataD, FunD, SigD)
+ , DerivClause (DerivClause)
+ , Exp (LitE)
+ , Lit (IntegerL)
, Name
- , Pat(ConP)
+ , Pat (ConP)
, Q
- , Type(AppT, ArrowT, ConT)
+ , Type (AppT, ArrowT, ConT)
, mkName
)
diff --git a/hsm-core/hsm-core.cabal b/hsm-core/hsm-core.cabal
index 163e430..6a0efff 100644
--- a/hsm-core/hsm-core.cabal
+++ b/hsm-core/hsm-core.cabal
@@ -6,6 +6,8 @@ version: 0.1.0.0
library
build-depends:
, base
+ , composition
+ , echo
, effectful-core
, optparse-applicative
, template-haskell
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
index fcb3a00..31b73d9 100644
--- a/hsm-gpio/Hsm/GPIO.hs
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -3,21 +3,22 @@
{-# LANGUAGE TypeFamilies #-}
module Hsm.GPIO
- ( GPIOPin(..)
+ ( GPIOPin (..)
, GPIO
, setPins
, setAllPins
, runGPIO
- ) where
+ )
+where
import Control.Monad (forM_, void)
import Control.Monad.Trans.Cont (evalCont)
import Data.Vector.Storable (fromList, replicate, unsafeWith)
-import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
-import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket)
import Foreign.C.String (withCString)
-import Foreign.C.Types (CSize(CSize), CUInt)
+import Foreign.C.Types (CSize (CSize), CUInt)
import Foreign.Ptr (Ptr)
import Hsm.Core.Bracket (bracketCont)
import Hsm.Core.Serial (makeSerial)
@@ -43,7 +44,7 @@ import Hsm.GPIO.FFI
, requestConfigNew
, requestConfigSetConsumer
)
-import Hsm.Log (Log, Severity(Info, Trace), logMsg)
+import Hsm.Log (Log, Severity (Info, Trace), logMsg)
import Prelude hiding (replicate)
$(makeSerial "GPIO" "Pin" "pinLine" ''CUInt $ [2 .. 17] <> [20 .. 27])
@@ -61,8 +62,8 @@ data GPIO (a :: * -> *) (b :: *)
type instance DispatchOf GPIO = Static WithSideEffects
-newtype instance StaticRep GPIO =
- GPIO (Ptr LineRequest)
+newtype instance StaticRep GPIO
+ = GPIO (Ptr LineRequest)
setPins :: (GPIO :> es, Log "gpio" :> es) => [GPIOPin] -> LineValue -> Eff es ()
setPins pins lineValue = do
diff --git a/hsm-gpio/Hsm/GPIO/FFI.hs b/hsm-gpio/Hsm/GPIO/FFI.hs
deleted file mode 100644
index 2589e5e..0000000
--- a/hsm-gpio/Hsm/GPIO/FFI.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-# LANGUAGE CApiFFI #-}
-
--- FFI bindings to `libgpiod` for direct GPIO hardware access.
---
--- Exposes only the minimal required subset of `libgpiod` functionality used by
--- this project. The bindings are suitable for low-level hardware control.
---
--- Future work could expand this into a comprehensive `gpiod` binding package.
-module Hsm.GPIO.FFI
- ( chipOpen
- , chipClose
- , input
- , output
- , LineValue
- , active
- , inactive
- , lineSettingsNew
- , lineSettingsFree
- , lineSettingsSetDirection
- , lineSettingsSetOutputValue
- , lineConfigNew
- , lineConfigFree
- , lineConfigAddLineSettings
- , requestConfigNew
- , requestConfigFree
- , requestConfigSetConsumer
- , LineRequest
- , chipRequestLines
- , lineRequestRelease
- , lineRequestSetValue
- , lineRequestSetValues
- ) where
-
-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 capi safe "gpiod.h gpiod_chip_open" chipOpen :: CString -> IO (Ptr Chip)
-
-foreign import capi safe "gpiod.h gpiod_chip_close" chipClose :: Ptr Chip -> IO ()
-
-data LineSettings
-
-newtype LineDirection =
- LineDirection CInt
- deriving (Show)
-
-foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT" input :: LineDirection
-
-foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT" output :: LineDirection
-
-newtype LineValue =
- LineValue CInt
- deriving (Show, Storable)
-
-foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE" active :: LineValue
-
-foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE" inactive :: LineValue
-
-foreign import capi safe "gpiod.h gpiod_line_settings_new" lineSettingsNew :: IO (Ptr LineSettings)
-
-foreign import capi safe "gpiod.h gpiod_line_settings_free" lineSettingsFree :: Ptr LineSettings -> IO ()
-
-foreign import capi safe "gpiod.h gpiod_line_settings_set_direction" lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
-
-foreign import capi safe "gpiod.h gpiod_line_settings_set_output_value" lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
-
-data LineConfig
-
-foreign import capi safe "gpiod.h gpiod_line_config_new" lineConfigNew :: IO (Ptr LineConfig)
-
-foreign import capi safe "gpiod.h gpiod_line_config_free" lineConfigFree :: Ptr LineConfig -> IO ()
-
-foreign import capi safe "gpiod.h gpiod_line_config_add_line_settings" lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
-
-data RequestConfig
-
-foreign import capi safe "gpiod.h gpiod_request_config_new" requestConfigNew :: IO (Ptr RequestConfig)
-
-foreign import capi safe "gpiod.h gpiod_request_config_free" requestConfigFree :: Ptr RequestConfig -> IO ()
-
-foreign import capi safe "gpiod.h gpiod_request_config_set_consumer" requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
-
-data LineRequest
-
-foreign import capi safe "gpiod.h gpiod_chip_request_lines" chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
-
-foreign import capi safe "gpiod.h gpiod_line_request_release" lineRequestRelease :: Ptr LineRequest -> IO ()
-
-foreign import capi safe "gpiod.h gpiod_line_request_set_value" lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
-
-foreign import capi safe "gpiod.h gpiod_line_request_set_values" lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
diff --git a/hsm-gpio/Hsm/GPIO/FFI.hsc b/hsm-gpio/Hsm/GPIO/FFI.hsc
new file mode 100644
index 0000000..d8b0f47
--- /dev/null
+++ b/hsm-gpio/Hsm/GPIO/FFI.hsc
@@ -0,0 +1,116 @@
+{-# LANGUAGE CApiFFI #-}
+
+-- FFI bindings to `libgpiod` for direct GPIO hardware access.
+--
+-- Exposes only the minimal required subset of `libgpiod` functionality used by
+-- this project. The bindings are suitable for low-level hardware control.
+--
+-- Future work could expand this into a comprehensive `gpiod` binding package.
+module Hsm.GPIO.FFI
+ ( chipOpen
+ , chipClose
+ , input
+ , output
+ , LineValue
+ , active
+ , inactive
+ , lineSettingsNew
+ , lineSettingsFree
+ , lineSettingsSetDirection
+ , lineSettingsSetOutputValue
+ , lineConfigNew
+ , lineConfigFree
+ , lineConfigAddLineSettings
+ , requestConfigNew
+ , requestConfigFree
+ , requestConfigSetConsumer
+ , LineRequest
+ , chipRequestLines
+ , lineRequestRelease
+ , lineRequestSetValue
+ , lineRequestSetValues
+ )
+where
+
+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 capi safe "gpiod.h gpiod_chip_open"
+ chipOpen :: CString -> IO (Ptr Chip)
+
+foreign import capi safe "gpiod.h gpiod_chip_close"
+ chipClose :: Ptr Chip -> IO ()
+
+data LineSettings
+
+newtype LineDirection
+ = LineDirection CInt
+ deriving Show
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT"
+ input :: LineDirection
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT"
+ output :: LineDirection
+
+newtype LineValue
+ = LineValue CInt
+ deriving (Show, Storable)
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE"
+ active :: LineValue
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE"
+ inactive :: LineValue
+
+foreign import capi safe "gpiod.h gpiod_line_settings_new"
+ lineSettingsNew :: IO (Ptr LineSettings)
+
+foreign import capi safe "gpiod.h gpiod_line_settings_free"
+ lineSettingsFree :: Ptr LineSettings -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_settings_set_direction"
+ lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
+
+foreign import capi safe "gpiod.h gpiod_line_settings_set_output_value"
+ lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
+
+data LineConfig
+
+foreign import capi safe "gpiod.h gpiod_line_config_new"
+ lineConfigNew :: IO (Ptr LineConfig)
+
+foreign import capi safe "gpiod.h gpiod_line_config_free"
+ lineConfigFree :: Ptr LineConfig -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_config_add_line_settings"
+ lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
+
+data RequestConfig
+
+foreign import capi safe "gpiod.h gpiod_request_config_new"
+ requestConfigNew :: IO (Ptr RequestConfig)
+
+foreign import capi safe "gpiod.h gpiod_request_config_free"
+ requestConfigFree :: Ptr RequestConfig -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_request_config_set_consumer"
+ requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
+
+data LineRequest
+
+foreign import capi safe "gpiod.h gpiod_chip_request_lines"
+ chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
+
+foreign import capi safe "gpiod.h gpiod_line_request_release"
+ lineRequestRelease :: Ptr LineRequest -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_request_set_value"
+ lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
+
+foreign import capi safe "gpiod.h gpiod_line_request_set_values"
+ lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
diff --git a/hsm-log/Hsm/Log.hs b/hsm-log/Hsm/Log.hs
index a0cf49c..99e5b7c 100644
--- a/hsm-log/Hsm/Log.hs
+++ b/hsm-log/Hsm/Log.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Hsm.Log
- ( Severity(Attention, Info, Trace)
+ ( Severity (Attention, Info, Trace)
, Log
, getLevel
, logMsg
@@ -13,16 +13,25 @@ module Hsm.Log
, runLogOpt
, runLogs
, runLogsOpt
- ) where
+ )
+where
import Control.Monad (when)
import Data.Function (applyWhen)
import Data.List (intercalate)
-import Data.Proxy (Proxy(Proxy))
+import Data.Proxy (Proxy (Proxy))
import Data.Time.Clock (getCurrentTime)
import Data.Time.ISO8601 (formatISO8601Millis)
-import Effectful (Dispatch(Static), DispatchOf, Eff, Effect, IOE, (:>))
-import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff, unsafeEff_)
+import Effectful (Dispatch (Static), DispatchOf, Eff, Effect, IOE, (:>))
+import Effectful.Dispatch.Static
+ ( SideEffects (WithSideEffects)
+ , StaticRep
+ , evalStaticRep
+ , getStaticRep
+ , unEff
+ , unsafeEff
+ , unsafeEff_
+ )
import GHC.Conc.Sync (fromThreadId, myThreadId)
import GHC.Records (HasField, getField)
import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal)
@@ -43,14 +52,15 @@ data Log (d :: Symbol) (a :: * -> *) (b :: *)
type instance DispatchOf (Log d) = Static WithSideEffects
-newtype instance StaticRep (Log d) =
- Log Severity
+newtype instance StaticRep (Log d)
+ = Log Severity
getLevel :: Log d :> es => Eff es Severity
getLevel = getStaticRep >>= \(Log level) -> return level
-logMsg ::
- forall d es. (KnownSymbol d, Log d :> es)
+logMsg
+ :: forall d es
+ . (KnownSymbol d, Log d :> es)
=> Severity
-> String
-> Eff es ()
@@ -59,24 +69,33 @@ logMsg severity message = do
when (severity <= level) . unsafeEff_ $ do
time <- formatISO8601Millis <$> getCurrentTime
domainAndThreadId <- myThreadId >>= \tid -> return . white $ symbolVal (Proxy @d) <> ":" <> show (fromThreadId tid)
- putStrLn $ unwords [time, domainAndThreadId, coloredShow severity, applyWhen (severity == Attention) red . intercalate "\n ... " $ lines message]
-
-makeLoggerIO ::
- forall d es. (KnownSymbol d, Log d :> es)
+ putStrLn $
+ unwords
+ [ time
+ , domainAndThreadId
+ , coloredShow severity
+ , applyWhen (severity == Attention) red . intercalate "\n ... " $ lines message
+ ]
+
+makeLoggerIO
+ :: forall d es
+ . (KnownSymbol d, Log d :> es)
=> Eff es (Severity -> String -> IO ())
makeLoggerIO = unsafeEff $ \env -> return $ \severity message -> unEff (logMsg severity message) env
type LoggerOptionPrefix = "logLevel_"
-runLog ::
- forall d es a. IOE :> es
+runLog
+ :: forall d es a
+ . IOE :> es
=> Severity
-> Eff (Log d : es) a
-> Eff es a
runLog = evalStaticRep . Log
-runLogOpt ::
- forall d f o es a. (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> es)
+runLogOpt
+ :: forall d f o es a
+ . (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> es)
=> o
-> Eff (Log d : es) a
-> Eff es a
@@ -92,7 +111,10 @@ instance Logs (o :: *) ('[] :: [Symbol]) (es :: [Effect]) where
runLogs = const id
runLogsOpt = const id
-instance (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, Logs o ds es) => Logs (o :: *) (d : ds :: [Symbol]) (es :: [Effect]) where
+instance
+ (AppendSymbol LoggerOptionPrefix d ~ f, HasField f o Severity, IOE :> Insert ds es, KnownSymbol d, Logs o ds es)
+ => Logs (o :: *) (d : ds :: [Symbol]) (es :: [Effect])
+ where
type Insert (d : ds) es = Log d : Insert ds es
runLogs level = runLogs @o @ds level . runLog @d level
runLogsOpt opts = runLogsOpt @o @ds opts . runLogOpt @d @f @o opts
diff --git a/hsm-log/Hsm/Log/Options.hs b/hsm-log/Hsm/Log/Options.hs
index cb44f70..0e00b32 100644
--- a/hsm-log/Hsm/Log/Options.hs
+++ b/hsm-log/Hsm/Log/Options.hs
@@ -3,25 +3,26 @@
module Hsm.Log.Options
( makeLoggerOptionParser
- ) where
+ )
+where
-import Data.Proxy (Proxy(Proxy))
+import Data.Proxy (Proxy (Proxy))
import GHC.TypeLits (symbolVal)
import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
import Hsm.Log (LoggerOptionPrefix, Severity)
import Language.Haskell.TH
- ( Bang(Bang)
- , Body(NormalB)
- , Clause(Clause)
- , Con(RecC)
- , Dec(DataD, FunD, SigD)
- , Exp(AppE, ConE, LitE, ParensE, UInfixE, VarE)
- , Lit(StringL)
+ ( Bang (Bang)
+ , Body (NormalB)
+ , Clause (Clause)
+ , Con (RecC)
+ , Dec (DataD, FunD, SigD)
+ , Exp (AppE, ConE, LitE, ParensE, UInfixE, VarE)
+ , Lit (StringL)
, Name
, Q
- , SourceStrictness(NoSourceStrictness)
- , SourceUnpackedness(NoSourceUnpackedness)
- , Type(AppT, ConT)
+ , SourceStrictness (NoSourceStrictness)
+ , SourceUnpackedness (NoSourceUnpackedness)
+ , Type (AppT, ConT)
, mkName
)
import Options.Applicative (Parser, auto, help, long, metavar, option, showDefault, value)
@@ -36,10 +37,11 @@ import Options.Applicative (Parser, auto, help, long, metavar, option, showDefau
-- $(makeLoggerOptionParser @'[ "cam", "web"] "Options" "parser" 'Info)
--
-- Generates:
--- * Record: `Options { logLevel_cam :: Severity, logLevel_web :: Severity }`
--- * Parser: `parser :: Parser Options` with default values set to `Info`
-makeLoggerOptionParser ::
- forall ls. KnownSymbols ls
+-- - Record: `Options { logLevel_cam :: Severity, logLevel_web :: Severity }`
+-- - Parser: `parser :: Parser Options` with default values set to `Info`
+makeLoggerOptionParser
+ :: forall ls
+ . KnownSymbols ls
=> String
-> String
-> Name
@@ -69,4 +71,6 @@ makeLoggerOptionParser dataNameString parserNameString defaultSeverity =
parserOptionValue = VarE 'value `AppE` ConE defaultSeverity
parserOptionMetavar = VarE 'metavar `AppE` LitE (StringL "LEVEL")
parserOptions logger = [parserOptionLong logger, parserOptionHelp logger, parserOptionShowDefault, parserOptionValue, parserOptionMetavar]
- parserApply expr logger = UInfixE expr (VarE '(<*>)) $ VarE 'option `AppE` VarE 'auto `AppE` ParensE (foldl1 parserConfigApply $ parserOptions logger)
+ parserApply expr logger =
+ UInfixE expr (VarE '(<*>)) $
+ VarE 'option `AppE` VarE 'auto `AppE` ParensE (foldl1 parserConfigApply $ parserOptions logger)
diff --git a/hsm-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs
index 2fd5955..bc31fbc 100644
--- a/hsm-pwm/Hsm/PWM.hs
+++ b/hsm-pwm/Hsm/PWM.hs
@@ -12,20 +12,21 @@
-- - SysFS Reference: https://forums.raspberrypi.com/viewtopic.php?t=359251
-- - UDEV Setup: https://forums.raspberrypi.com/viewtopic.php?t=316514
module Hsm.PWM
- ( PWMChannel(..)
+ ( PWMChannel (..)
, PWM
, setCycleDuration
, runPWM
- ) where
+ )
+where
import Control.Concurrent (threadDelay)
import Control.Monad (forM_)
import Control.Monad.Loops (untilM_)
-import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
-import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, unsafeEff_)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, unsafeEff_)
import Effectful.Exception (bracket_)
import Hsm.Core.Serial (makeSerial)
-import Hsm.Log (Log, Severity(Info, Trace), logMsg)
+import Hsm.Log (Log, Severity (Info, Trace), logMsg)
import System.FilePath ((</>))
import System.Posix.Files (fileAccess)
@@ -35,8 +36,8 @@ data PWM (a :: * -> *) (b :: *)
type instance DispatchOf PWM = Static WithSideEffects
-newtype instance StaticRep PWM =
- PWM ()
+newtype instance StaticRep PWM
+ = PWM ()
chipPath :: FilePath
chipPath = "/sys/class/pwm/pwmchip0"
diff --git a/hsm-repl/Hsm/Repl.hs b/hsm-repl/Hsm/Repl.hs
index 6bcf39d..00012c5 100644
--- a/hsm-repl/Hsm/Repl.hs
+++ b/hsm-repl/Hsm/Repl.hs
@@ -4,17 +4,25 @@ module Hsm.Repl
( Repl
, repl
, runRepl
- ) where
+ )
+where
import Control.Monad (forM_)
-import Data.Typeable (Proxy(Proxy), Typeable, typeRep)
-import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
-import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
+import Data.Typeable (Proxy (Proxy), Typeable, typeRep)
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Generic.Data.Function.Common.Generic.Meta (KnownSymbols, symbolVals)
-import Hsm.Log (Log, Severity(Attention, Info, Trace), logMsg)
-import Language.Haskell.Interpreter (GhcError(errMsg), InterpreterError(WontCompile), as, interpret, runInterpreter, setImports)
+import Hsm.Log (Log, Severity (Attention, Info, Trace), logMsg)
+import Language.Haskell.Interpreter
+ ( GhcError (errMsg)
+ , InterpreterError (WontCompile)
+ , as
+ , interpret
+ , runInterpreter
+ , setImports
+ )
import String.ANSI (blue)
import System.Console.Haskeline (defaultSettings, getInputLine, handleInterrupt, withInterrupt)
import System.Console.Haskeline.IO (InputState, cancelInput, initializeInput, queryInput)
@@ -23,18 +31,20 @@ data Repl (p :: Symbol) (ms :: [Symbol]) (t :: *) (a :: * -> *) (b :: *)
type instance DispatchOf (Repl p ms t) = Static WithSideEffects
-newtype instance StaticRep (Repl p ms t) =
- Repl InputState
+newtype instance StaticRep (Repl p ms t)
+ = Repl InputState
-repl ::
- forall p ms t es. (KnownSymbol p, KnownSymbols ms, Log "repl" :> es, Repl p ms t :> es, Show t, Typeable t)
+repl
+ :: forall p ms t es
+ . (KnownSymbol p, KnownSymbols ms, Log "repl" :> es, Repl p ms t :> es, Show t, Typeable t)
=> Eff es (Maybe t)
repl = query >>= maybe (return Nothing) parse
where
query = do
Repl inputState <- getStaticRep
logMsg Trace $ "Expecting a value of type: " <> show (typeRep $ Proxy @t)
- unsafeEff_ . queryInput inputState . handleInterrupt (return Nothing) . withInterrupt . getInputLine . blue $ symbolVal (Proxy @p)
+ unsafeEff_ . queryInput inputState . handleInterrupt (return Nothing) . withInterrupt . getInputLine . blue $
+ symbolVal (Proxy @p)
parse string = do
logMsg Trace $ "Parsing string: " <> string
eitherValue <-
@@ -52,8 +62,9 @@ repl = query >>= maybe (return Nothing) parse
logMsg Attention $ show err
repl
-runRepl ::
- forall p ms t es a. (IOE :> es, Log "repl" :> es)
+runRepl
+ :: forall p ms t es a
+ . (IOE :> es, Log "repl" :> es)
=> Eff (Repl p ms t : es) a
-> Eff es a
runRepl action = bracket inputStateAlloc inputStateDealloc $ \inputState -> evalStaticRep (Repl inputState) action
diff --git a/hsm-repl/Test/Repl.hs b/hsm-repl/Test/Repl.hs
index 8588718..7d1431c 100644
--- a/hsm-repl/Test/Repl.hs
+++ b/hsm-repl/Test/Repl.hs
@@ -1,7 +1,8 @@
import Control.Monad.Loops (whileJust_)
+import Data.Function ((&))
import Effectful (runEff)
-import Hsm.Log (Severity(Trace), runLog)
+import Hsm.Log (Severity (Trace), runLog)
import Hsm.Repl (repl, runRepl)
main :: IO ()
-main = runEff . runLog @"repl" Trace . runRepl @"exec-repl λ " @'[ "Prelude"] @[Bool] $ whileJust_ repl return
+main = whileJust_ repl return & runRepl @"exec-repl λ " @'["Prelude"] @[Bool] & runLog @"repl" Trace & runEff
diff --git a/hsm-web/Hsm/Web.hs b/hsm-web/Hsm/Web.hs
index 975f556..b8f8881 100644
--- a/hsm-web/Hsm/Web.hs
+++ b/hsm-web/Hsm/Web.hs
@@ -5,24 +5,32 @@ module Hsm.Web
( Web
, runServer
, runWeb
- ) where
-
-import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
-import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff)
+ )
+where
+
+import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, (:>))
+import Effectful.Dispatch.Static
+ ( SideEffects (WithSideEffects)
+ , StaticRep
+ , evalStaticRep
+ , getStaticRep
+ , unEff
+ , unsafeEff
+ )
import Effectful.Dispatch.Static.Primitive (Env)
import Effectful.Exception (finally)
import Hsm.Cam (Cam, capturePng)
-import Hsm.Log (Log, Severity(Info, Trace), logMsg, makeLoggerIO)
+import Hsm.Log (Log, Severity (Info, Trace), logMsg, makeLoggerIO)
import Network.Wai.Handler.Warp (defaultSettings, setLogger)
import Paths_hsm_web (getDataFileName)
-import Web.Scotty (Options(settings, verbose), defaultOptions, file, get, liftIO, raw, scottyOpts, setHeader)
+import Web.Scotty (Options (settings, verbose), defaultOptions, file, get, liftIO, raw, scottyOpts, setHeader)
data Web (a :: * -> *) (b :: *)
type instance DispatchOf Web = Static WithSideEffects
-newtype instance StaticRep Web =
- Web Options
+newtype instance StaticRep Web
+ = Web Options
server :: (Cam :> es, Log "cam" :> es) => Options -> Env es -> IO ()
server options env = do
@@ -46,6 +54,6 @@ runWeb :: (IOE :> es, Log "scotty" :> es, Log "web" :> es) => Eff (Web : es) a -
runWeb action = do
logMsg @"web" Info "Registering logger for scotty web server"
scottyLogger <- makeLoggerIO @"scotty" >>= return . logRequest
- evalStaticRep (Web $ defaultOptions {verbose = 0, settings = setLogger scottyLogger defaultSettings}) action
+ evalStaticRep (Web $ defaultOptions{verbose = 0, settings = setLogger scottyLogger defaultSettings}) action
where
logRequest loggerIO request status fileSize = loggerIO Trace $ unwords [show request, show status, show fileSize]
diff --git a/hsm-web/Main.hs b/hsm-web/Main.hs
index 2b6c44b..6cbfa31 100644
--- a/hsm-web/Main.hs
+++ b/hsm-web/Main.hs
@@ -1,19 +1,19 @@
{-# LANGUAGE TemplateHaskell #-}
+import Data.Function ((&))
import Effectful (runEff)
import Hsm.Cam (runCam)
-import Hsm.Core.App (runApp)
-import Hsm.Log (Severity(Info), runLogsOpt)
+import Hsm.Core.App (bootstrapAppNoEcho)
+import Hsm.Log (Severity (Info), runLogsOpt)
import Hsm.Log.Options (makeLoggerOptionParser)
import Hsm.Web (runServer, runWeb)
-
-- Import full module for cleaner `-ddump-splices` output
-- Avoids package/module qualifiers in generated code
import Options.Applicative
-type Loggers = '[ "cam", "libcamera", "scotty", "web"]
+type Loggers = '["cam", "libcamera", "scotty", "web"]
$(makeLoggerOptionParser @Loggers "Options" "parser" 'Info)
main :: IO ()
-main = runApp parser "Launch HsMouse Web Server" $ \opts -> runLogsOpt @Options @Loggers opts . runCam . runWeb $ runServer
+main = bootstrapAppNoEcho parser "Launch HsMouse Web Server" $ \opts -> runServer & runWeb & runCam & runLogsOpt @Options @Loggers opts & runEff
powered by cgit v1.2.1, back to main portfolio site