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
90
91
92
|
{-# 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.Concurrent (Concurrent, runConcurrent, threadDelay)
import Effectful.Log (Log, LogLevel(LogAttention), runLog)
import Effectful.Reader.Static (Reader, asks, 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 qualified as G
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 :: G.GPIO
, gpioError :: G.GPIO
, period :: Word
, 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 ::
(Concurrent :> es, G.GPIOEffect Bool :> es, Log :> es, Reader Env :> es)
=> S.Stream (Eff es) Bool
-> Eff es ()
handle = S.fold S.drain . S.mapM handler
where
sleep = asks period >>= threadDelay . fromIntegral
handler sta = do
G.setPins G.active sta >> sleep
G.setPins G.inactive sta >> sleep
mapper :: Env -> Bool -> Set G.GPIO
mapper env True = singleton env.gpioOk
mapper env False = singleton env.gpioError
-- Status Service: Periodically blinks a GPIO pin and listens for error
-- messages. Upon receiving an error, it switches to a different pin.
main :: IO ()
main =
launch "status" withoutInputEcho $ \env logger level ->
(poll & F.fsm @_ @_ @Env @() & handle)
& runClient @Env
& G.runGPIO @Env (mapper env)
& runConcurrent
& evalState ()
& evalState stateOk
& runLog env.name logger level
& runReader env
& runResource
& runEff
|
