diff options
Diffstat (limited to 'hsm-status')
-rw-r--r-- | hsm-status/Hsm/Status.hs | 41 | ||||
-rw-r--r-- | hsm-status/Hsm/Status/Error.hs | 13 | ||||
-rw-r--r-- | hsm-status/Main.hs | 86 | ||||
-rw-r--r-- | hsm-status/hsm-status.cabal | 27 |
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 |