Adds error and dummy-fail service

3 files changed, 138 insertions, 0 deletions

diff --git a/hsm-status/Hsm/Status/Error.hs b/hsm-status/Hsm/Status/Error.hs
new file mode 100644
index 0000000..2853d6b
--- /dev/null
+++ b/hsm-status/Hsm/Status/Error.hs
@@ -0,0 +1,13 @@
+{-# 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
new file mode 100644
index 0000000..6220474
--- /dev/null
+++ b/hsm-status/Main.hs
@@ -0,0 +1,86 @@
+{-# 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
new file mode 100644
index 0000000..64528bd
--- /dev/null
+++ b/hsm-status/hsm-status.cabal
@@ -0,0 +1,39 @@
+cabal-version: 3.4
+author:        Paul Oliver
+build-type:    Simple
+maintainer:    contact@pauloliver.dev
+name:          hsm-status
+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
+
+  main-is:          Main.hs
+  other-modules:    Hsm.Status.Error
+  ghc-options:      -Wall -Wunused-packages
+
+  if !arch(x86_64)
+    ghc-options: -optl=-mno-fix-cortex-a53-835769
+
+  default-language: GHC2021