1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
import Data.ByteString (ByteString)
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.Message (body)
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 [ByteString] Bool Env ()
-> [ByteString]
-> F.FsmOutput [ByteString] Bool Env ()
result sta next errs =
F.FsmOutput (Just $ F.FsmResult sta () next) (logError <$> errs)
where
logError err =
let Error code msg = body err
in ( LogAttention
, "Error received with code "
<> pack (show code)
<> " and message: "
<> msg)
stateOk :: F.FsmState [ByteString] Bool Env ()
stateOk =
F.FsmState "ok" $ \errs _ _ ->
if null errs
then result True stateOk errs
else result False stateError errs
stateError :: F.FsmState [ByteString] Bool Env ()
stateError = F.FsmState "error" $ \errs _ _ -> result False stateError errs
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 & F.fsm @_ @_ @Env @() & handle)
& runClient @Env
& runGPIO (mapper env)
& evalState ()
& evalState stateOk
& runLog env.name logger level
& runReader env
& runResource
& runEff
|
