From 70d3e37b1a088209fe84abf07a39d14dec116c6b Mon Sep 17 00:00:00 2001
From: Paul Oliver <contact@pauloliver.dev>
Date: Sat, 24 Aug 2024 11:57:18 -0700
Subject: Initial commit

---
 hsm-dummy-pulser/Main.hs | 85 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 85 insertions(+)
 create mode 100644 hsm-dummy-pulser/Main.hs

(limited to 'hsm-dummy-pulser/Main.hs')

diff --git a/hsm-dummy-pulser/Main.hs b/hsm-dummy-pulser/Main.hs
new file mode 100644
index 0000000..a432301
--- /dev/null
+++ b/hsm-dummy-pulser/Main.hs
@@ -0,0 +1,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
-- 
cgit v1.2.1