diff options
| -rw-r--r-- | hsm-dummy-fail/Main.hs | 47 | ||||
| -rw-r--r-- | hsm-dummy-fail/hsm-dummy-fail.cabal | 26 | ||||
| -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 | 39 | ||||
| -rw-r--r-- | servconf.yaml | 13 | ||||
| -rw-r--r-- | stack.yaml | 2 |
7 files changed, 226 insertions, 0 deletions
diff --git a/hsm-dummy-fail/Main.hs b/hsm-dummy-fail/Main.hs new file mode 100644 index 0000000..4e293c8 --- /dev/null +++ b/hsm-dummy-fail/Main.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +import Data.Function ((&)) +import Data.Text (Text) +import Effectful (Eff, (:>), runEff) +import Effectful.Concurrent (Concurrent, runConcurrent, threadDelay) +import Effectful.Log (runLog) +import Effectful.Reader.Static (Reader, asks, runReader) +import Effectful.Resource (runResource) +import Hsm.Core.App (launch) +import Hsm.Core.Env (deriveFromYaml) +import Hsm.Core.Zmq.Server (runServer, send) +import Hsm.Status.Error (Error(Error)) +import Streamly.Data.Stream (Stream, fromEffect) +import System.IO.Echo (withoutInputEcho) + +data Env = Env + { name :: Text + , pubEp :: Text + , alive :: Int + } + +$(deriveFromYaml ''Env) + +singleError :: (Concurrent :> es, Reader Env :> es) => Stream (Eff es) Error +singleError = + fromEffect $ do + -- Seemingly, the service needs to be alive for a bit for ZMQ comms to + -- kick in. + asks alive >>= threadDelay + return $ Error 0 "Sent from dummy-fail service" + +-- Dummy fail service: +-- Proof of concept. Publishes a single error that can be catched by a +-- listening client. +main :: IO () +main = + launch @Env "dummy-fail" withoutInputEcho $ \env logger level -> + (singleError & send @Env) + & runServer @Env + & runConcurrent + & runLog env.name logger level + & runReader env + & runResource + & runEff diff --git a/hsm-dummy-fail/hsm-dummy-fail.cabal b/hsm-dummy-fail/hsm-dummy-fail.cabal new file mode 100644 index 0000000..269ea9c --- /dev/null +++ b/hsm-dummy-fail/hsm-dummy-fail.cabal @@ -0,0 +1,26 @@ +cabal-version: 3.4 +author: Paul Oliver +build-type: Simple +maintainer: contact@pauloliver.dev +name: hsm-dummy-fail +version: 0.1.0.0 + +executable dummy-fail + build-depends: + , base + , echo + , effectful + , hsm-core + , hsm-status + , log-effectful + , resourcet-effectful + , streamly-core + , text + + main-is: Main.hs + ghc-options: -Wall -Wunused-packages + + if !arch(x86_64) + ghc-options: -optl=-mno-fix-cortex-a53-835769 + + default-language: GHC2021 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 diff --git a/servconf.yaml b/servconf.yaml index 0eb74e7..a014ade 100644 --- a/servconf.yaml +++ b/servconf.yaml @@ -8,6 +8,10 @@ dummy-blinker: - GPIO27 name: blinker period: 1000 +dummy-fail: + alive: 1000000 + name: fail + pubEp: tcp://0.0.0.0:10002 dummy-poller: name: poller period: 3000000 @@ -26,3 +30,12 @@ dummy-receiver: - tcp://0.0.0.0:10001 topics: - pulser +status: + gpioError: GPIO17 + gpioOk: GPIO22 + name: status + period: 1000 + subEps: + - tcp://0.0.0.0:10002 + topics: + - fail @@ -6,8 +6,10 @@ packages: - hsm-command - hsm-core - hsm-dummy-blinker + - hsm-dummy-fail - hsm-dummy-poller - hsm-dummy-pulser - hsm-dummy-receiver - hsm-gpio + - hsm-status snapshot: lts-23.3 |