aboutsummaryrefslogtreecommitdiff
path: root/hsm-status
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-status')
-rw-r--r--hsm-status/Hsm/Status.hs41
-rw-r--r--hsm-status/Hsm/Status/Error.hs13
-rw-r--r--hsm-status/Main.hs86
-rw-r--r--hsm-status/hsm-status.cabal27
4 files changed, 43 insertions, 124 deletions
diff --git a/hsm-status/Hsm/Status.hs b/hsm-status/Hsm/Status.hs
new file mode 100644
index 0000000..8154611
--- /dev/null
+++ b/hsm-status/Hsm/Status.hs
@@ -0,0 +1,41 @@
+{-# 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
+
+data StatusEnv = StatusEnv
+ { gpioOk :: GPIO
+ , gpioError :: GPIO
+ }
+
+statusEnvDefault :: StatusEnv
+statusEnvDefault = StatusEnv {gpioOk = GPIO17, gpioError = GPIO27}
+
+status ::
+ HasField "statusEnv" env StatusEnv
+ => Ptr LineRequest
+ -> env
+ -> [Bool]
+ -> IO ()
+status lineRequest env signals = do
+ 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"]
diff --git a/hsm-status/Hsm/Status/Error.hs b/hsm-status/Hsm/Status/Error.hs
deleted file mode 100644
index 2853d6b..0000000
--- a/hsm-status/Hsm/Status/Error.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-
-module Hsm.Status.Error
- ( Error(Error)
- ) where
-
-import Data.Binary (Binary)
-import Data.Text (Text)
-import GHC.Generics (Generic)
-
-data Error =
- Error Int Text
- deriving (Binary, Generic, Show)
diff --git a/hsm-status/Main.hs b/hsm-status/Main.hs
deleted file mode 100644
index 6220474..0000000
--- a/hsm-status/Main.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-import Data.Function ((&))
-import Data.Set (Set, singleton)
-import Data.Text (Text, pack)
-import Effectful (Eff, (:>), runEff)
-import Effectful.Log (Log, LogLevel(LogAttention), runLog)
-import Effectful.Reader.Static (Reader, ask, runReader)
-import Effectful.Resource (runResource)
-import Effectful.State.Static.Local (evalState)
-import Hsm.Core.App (launch)
-import Hsm.Core.Env (deriveFromYaml)
-import Hsm.Core.Fsm qualified as F
-import Hsm.Core.Zmq.Client (poll, runClient)
-import Hsm.GPIO (GPIO, GPIOEffect, runGPIO, toggle)
-import Hsm.Status.Error (Error(Error))
-import Streamly.Data.Fold qualified as S (drain)
-import Streamly.Data.Stream qualified as S (Stream, fold, mapM)
-import System.IO.Echo (withoutInputEcho)
-
-data Env = Env
- { name :: Text
- , gpioOk :: GPIO
- , gpioError :: GPIO
- , period :: Int
- , subEps :: [Text]
- , topics :: [Text]
- }
-
-$(deriveFromYaml ''Env)
-
-result ::
- Bool
- -> F.FsmState [Error] Bool Env ()
- -> [Error]
- -> F.FsmOutput [Error] Bool Env ()
-result sta next es =
- F.FsmOutput (Just $ F.FsmResult sta () next) (logError <$> es)
- where
- logError (Error code msg) =
- ( LogAttention
- , "Error received with code "
- <> pack (show code)
- <> " and message: "
- <> msg)
-
-stateOk :: F.FsmState [Error] Bool Env ()
-stateOk =
- F.FsmState "ok" $ \msg _ _ ->
- if null msg
- then result True stateOk msg
- else result False stateError msg
-
-stateError :: F.FsmState [Error] Bool Env ()
-stateError = F.FsmState "error" $ \msg _ _ -> result False stateError msg
-
-handle ::
- (GPIOEffect Bool :> es, Log :> es, Reader Env :> es)
- => S.Stream (Eff es) Bool
- -> Eff es ()
-handle = S.fold S.drain . S.mapM handler
- where
- handler sta = do
- env <- ask @Env
- toggle False sta [env.period, env.period, 0]
-
-mapper :: Env -> Bool -> Set GPIO
-mapper env True = singleton env.gpioOk
-mapper env False = singleton env.gpioError
-
--- Status service blinks a GPIO pin periodically and listens for error
--- messages. If an error is received it switches to a different pin.
-main :: IO ()
-main =
- launch "status" withoutInputEcho $ \env logger level ->
- (poll @_ @Error & F.fsm @_ @_ @Env @() & handle)
- & runClient @Env
- & runGPIO (mapper env)
- & evalState ()
- & evalState stateOk
- & runLog env.name logger level
- & runReader env
- & runResource
- & runEff
diff --git a/hsm-status/hsm-status.cabal b/hsm-status/hsm-status.cabal
index 64528bd..66560e8 100644
--- a/hsm-status/hsm-status.cabal
+++ b/hsm-status/hsm-status.cabal
@@ -8,32 +8,9 @@ version: 0.1.0.0
library
build-depends:
, base
- , binary
- , text
-
- exposed-modules: Hsm.Status.Error
- ghc-options: -Wall -Wunused-packages
- default-language: GHC2021
-
-executable status
- build-depends:
- , base
- , binary
- , containers
- , echo
- , effectful-core
- , hsm-core
, hsm-gpio
- , log-effectful
- , resourcet-effectful
- , streamly-core
- , text
+ , hsm-log
- main-is: Main.hs
- other-modules: Hsm.Status.Error
+ exposed-modules: Hsm.Status
ghc-options: -Wall -Wunused-packages
-
- if !arch(x86_64)
- ghc-options: -optl=-mno-fix-cortex-a53-835769
-
default-language: GHC2021