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
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
-- Proof of concept application, defines custom @Producer@ and FSM @Pipe@
-- components. Publishes a new number (in sequence) through ZMQ every second.
-- Throws an exception after a set number of pulses is reached.
module Main
( main
)
where
import Control.Concurrent (threadDelay)
import Control.Exception.Safe (StringException, throwString)
import Control.Monad (forever)
import Control.Monad.Extra (whenM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (asks)
import Control.Monad.State (get, gets, modify)
import Data.Aeson (FromJSON)
import Data.Function ((&))
import Data.Text (Text, pack)
import Effectful (IOE, runEff)
import Effectful.Log (Log, localDomain, logInfo_, logTrace_, runLog)
import Effectful.Reader.Static (Reader, runReader)
import Effectful.Resource (Resource, runResource)
import Effectful.State.Static.Local (State, evalState)
import GHC.Generics (Generic)
import Hsm.Core.App (launch)
import Hsm.Core.Fsm (FsmC, Method (Method), fsm)
import Hsm.Core.Pipes (Pipe, Producer, await, runEffect, yield, (>->))
import Hsm.Core.Zmq (server)
data Env = Env
{ name :: Text
, pubEp :: Text
, pulses :: Int
}
deriving (FromJSON, Generic)
type Effs = [Log, Reader Env, Resource, State Int, IOE]
type Pulser = Producer () Env Int Effs
type FsmMethodC es = (FsmC Env Int StringException es)
type FsmMethod es = Method () Int Env Int StringException es
type FsmPipe es = Pipe () Int Env Int es
pulser :: Pulser ()
pulser =
localDomain "pulser" $
forever $
liftIO (threadDelay 1000000) >> logTrace_ "Tick" >> yield ()
stateRun :: FsmMethodC es => FsmMethod es
stateRun =
Method "run" $ do
check >> await >> modify succ >> report >> get >>= yield
return stateRun
where
check :: FsmMethodC es => FsmPipe es ()
check =
asks pulses >>= \top ->
whenM (gets (== top)) $
throwString $
"Reached " <> show top <> " pulses"
report :: FsmMethodC es => FsmPipe es ()
report = get >>= logInfo_ . mappend "Sending pulse #" . pack . show
stateError :: FsmMethodC es => FsmMethod es
stateError = Method "error" $ logInfo_ "Doing nothing" >> forever await
main :: IO ()
main =
launch "dummy-pulser" $ \logger level e ->
(pulser >-> fsm stateRun stateError >-> server)
& runEffect
& runLog e.name logger level
& runReader e
& runResource
& evalState 0
& runEff
|
