aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hsm-command/Hsm/Command/Command.hs5
-rw-r--r--hsm-command/Hsm/Command/Readline.hs23
-rw-r--r--hsm-core/Hsm/Core/Env.hs7
-rw-r--r--hsm-core/Hsm/Core/Fsm.hs9
-rw-r--r--hsm-core/Hsm/Core/Zmq.hs25
-rw-r--r--hsm-core/Hsm/Core/Zmq/Client.hs59
-rw-r--r--hsm-core/Hsm/Core/Zmq/Server.hs25
-rw-r--r--hsm-dummy-blinker/Main.hs27
-rw-r--r--hsm-dummy-poller/Main.hs5
-rw-r--r--hsm-dummy-pulser/Main.hs4
-rw-r--r--hsm-dummy-receiver/Main.hs14
-rw-r--r--hsm-gpio/Hsm/GPIO.hs31
12 files changed, 82 insertions, 152 deletions
diff --git a/hsm-command/Hsm/Command/Command.hs b/hsm-command/Hsm/Command/Command.hs
index 3b53287..53964c4 100644
--- a/hsm-command/Hsm/Command/Command.hs
+++ b/hsm-command/Hsm/Command/Command.hs
@@ -39,13 +39,10 @@ data Command
| Rotate Angle Speed Int
deriving (Binary, Generic, Read, Show)
-commandStream ::
- forall es. (Log :> es, Readline :> es)
- => S.Stream (Eff es) Command
+commandStream :: (Log :> es, Readline :> es) => S.Stream (Eff es) Command
commandStream =
S.mapMaybeM (parse . fromJust) $ S.takeWhile isJust $ S.repeatM readline
where
- parse :: String -> Eff es (Maybe Command)
parse string =
case readEither string of
Left err -> logAttention_ (pack err) >> return Nothing
diff --git a/hsm-command/Hsm/Command/Readline.hs b/hsm-command/Hsm/Command/Readline.hs
index 428ed50..1caa562 100644
--- a/hsm-command/Hsm/Command/Readline.hs
+++ b/hsm-command/Hsm/Command/Readline.hs
@@ -22,28 +22,19 @@ type instance DispatchOf Readline = Static S.WithSideEffects
newtype instance S.StaticRep Readline =
Readline H.InputState
-readline ::
- forall es. (Log :> es, Readline :> es)
- => Eff es (Maybe String)
+readline :: (Log :> es, Readline :> es) => Eff es (Maybe String)
readline = do
flushLogger
Readline hdl <- S.getStaticRep
- S.unsafeEff_ $ nextLine hdl
- where
- nextLine :: H.InputState -> IO (Maybe String)
- nextLine hdl =
- H.queryInput hdl
- $ H.handleInterrupt (return Nothing)
- $ H.withInterrupt
- $ H.getInputLine "% "
+ S.unsafeEff_
+ $ H.queryInput hdl
+ $ H.handleInterrupt (return Nothing)
+ $ H.withInterrupt
+ $ H.getInputLine "% "
runReadline :: (IOE :> es, Resource :> es) => Eff (Readline : es) a -> Eff es a
runReadline action = do
- handle <- snd <$> allocate istate H.cancelInput
+ handle <- snd <$> allocate (H.initializeInput settings) H.cancelInput
S.evalStaticRep (Readline handle) action
where
- settings :: H.Settings IO
settings = H.defaultSettings {H.historyFile = Just ".hsm_command_history"}
- --
- istate :: IO H.InputState
- istate = H.initializeInput settings
diff --git a/hsm-core/Hsm/Core/Env.hs b/hsm-core/Hsm/Core/Env.hs
index 4e7986f..8ef7464 100644
--- a/hsm-core/Hsm/Core/Env.hs
+++ b/hsm-core/Hsm/Core/Env.hs
@@ -3,9 +3,9 @@ module Hsm.Core.Env
, deriveFromYaml
) where
-import Data.Aeson (FromJSON, Result(Error, Success), Value, fromJSON)
+import Data.Aeson (FromJSON, Result(Error, Success), fromJSON)
import Data.Aeson.Key (fromText)
-import Data.Aeson.KeyMap (KeyMap, (!?))
+import Data.Aeson.KeyMap ((!?))
import Data.Aeson.TH (defaultOptions, deriveFromJSON, rejectUnknownFields)
import Data.Maybe (fromMaybe)
import Data.Text (Text, unpack)
@@ -15,13 +15,10 @@ import Language.Haskell.TH (Dec, Name, Q)
environment :: FromJSON env => Text -> Text -> IO env
environment name = fmap (check . fromJSON . load) . decodeFileThrow . unpack
where
- load :: KeyMap Value -> Value
load keymap =
fromMaybe
(error $ "Service configuration for " <> unpack name <> " not found)")
$ keymap !? fromText name
- --
- check :: Result env -> env
check (Success env) = env
check (Error str) = error str
diff --git a/hsm-core/Hsm/Core/Fsm.hs b/hsm-core/Hsm/Core/Fsm.hs
index 6f9910e..d1c2f5d 100644
--- a/hsm-core/Hsm/Core/Fsm.hs
+++ b/hsm-core/Hsm/Core/Fsm.hs
@@ -39,23 +39,18 @@ fsm ::
-> S.Stream (Eff es) o
fsm = S.mapM (return . fromJust) . S.takeWhile isJust . S.mapM run
where
- exit :: Eff es (Maybe o)
exit = do
logAttention_ "No state returned, exiting FSM"
return Nothing
- --
- push :: FsmResult i o env sta -> Eff es (Maybe o)
push (FsmResult out sta next) = do
put sta
put next
return $ Just out
- --
- run :: i -> Eff es (Maybe o)
run input =
localDomain "fsm" $ do
FsmState name action <- get
- sta <- get
- env <- ask
+ sta <- get @sta
+ env <- ask @env
logTrace_ $ "Entering state " <> name
FsmOutput res logs <- return $ action input env sta
localDomain name $ mapM_ logTup logs
diff --git a/hsm-core/Hsm/Core/Zmq.hs b/hsm-core/Hsm/Core/Zmq.hs
index 8c12133..2f70d48 100644
--- a/hsm-core/Hsm/Core/Zmq.hs
+++ b/hsm-core/Hsm/Core/Zmq.hs
@@ -4,7 +4,6 @@ module Hsm.Core.Zmq
( withSocket
) where
-import Data.Text (Text)
import Effectful (Eff, IOE, (:>))
import Effectful.Log (Log, LogLevel(LogTrace))
import Effectful.Resource (Resource, allocate)
@@ -12,23 +11,19 @@ import Hsm.Core.Log (withLogIO)
import System.ZMQ4 qualified as Z
withSocket ::
- forall t es. (Z.SocketType t, IOE :> es, Log :> es, Resource :> es)
+ (Z.SocketType t, IOE :> es, Log :> es, Resource :> es)
=> t
-> Eff es (Z.Socket t)
withSocket stype = withLogIO >>= bracket
where
- bracket :: (LogLevel -> Text -> IO ()) -> Eff es (Z.Socket t)
bracket logIO = snd . snd <$> allocate acquire release
where
- acquire :: IO (Z.Context, Z.Socket t)
- acquire = do
- logIO LogTrace "Acquiring ZMQ context"
- cont <- Z.context
- sock <- Z.socket cont stype
- return (cont, sock)
- --
- release :: (Z.Context, Z.Socket t) -> IO ()
- release (cont, sock) = do
- logIO LogTrace "Releasing ZMQ context"
- Z.close sock
- Z.shutdown cont
+ acquire =
+ logIO LogTrace "Acquiring ZMQ context" >> do
+ cont <- Z.context
+ sock <- Z.socket cont stype
+ return (cont, sock)
+ release (cont, sock) =
+ logIO LogTrace "Releasing ZMQ context" >> do
+ Z.close sock
+ Z.shutdown cont
diff --git a/hsm-core/Hsm/Core/Zmq/Client.hs b/hsm-core/Hsm/Core/Zmq/Client.hs
index 793841e..6093e54 100644
--- a/hsm-core/Hsm/Core/Zmq/Client.hs
+++ b/hsm-core/Hsm/Core/Zmq/Client.hs
@@ -11,6 +11,7 @@ module Hsm.Core.Zmq.Client
, runClient
) where
+import Control.Monad (forM_)
import Control.Monad.Loops (whileM)
import Data.Binary (Binary)
import Data.Text (Text, pack, unpack)
@@ -50,30 +51,23 @@ receiver = do
<> pack (show $ body @a message)
return $ body message
-receive ::
- forall es a. (Log :> es, Client :> es, Binary a, Show a)
- => Stream (Eff es) a
+receive :: (Log :> es, Client :> es, Binary a, Show a) => Stream (Eff es) a
receive = repeatM receiver
-poll ::
- forall es a. (Log :> es, Client :> es, Binary a, Show a)
- => Stream (Eff es) [a]
-poll = repeatM poller
+poll :: (Log :> es, Client :> es, Binary a, Show a) => Stream (Eff es) [a]
+poll =
+ repeatM $ do
+ ms <- whileM newMsg receiver
+ localDomain domain
+ $ localDomain "poller"
+ $ logTrace_
+ $ pack (show $ length ms) <> " new message(s) on queue"
+ return ms
where
- newMsg :: Eff es Bool
newMsg = do
Client sock <- E.getStaticRep
peek <- E.unsafeEff_ $ Z.poll 0 [Z.Sock sock [Z.In] Nothing]
return $ peek /= [[]]
- --
- poller :: Eff es [a]
- poller = do
- ms <- whileM newMsg receiver
- localDomain domain
- $ localDomain "poller"
- $ logTrace_
- $ pack (show $ length ms) <> " new message(s) on queue"
- return ms
runClient ::
forall env es a.
@@ -86,23 +80,14 @@ runClient ::
)
=> Eff (Client : es) a
-> Eff es a
-runClient action = withSocket Z.Sub >>= run
- where
- run :: Z.Socket Z.Sub -> Eff es a
- run sock = E.evalStaticRep (Client sock) $ initialize >> action
- where
- connect :: Text -> Eff (Client : es) ()
- connect = E.unsafeEff_ . Z.connect sock . unpack
- --
- subscribe :: Text -> Eff (Client : es) ()
- subscribe = E.unsafeEff_ . Z.subscribe sock . encodeUtf8
- --
- initialize :: Eff (Client : es) ()
- initialize =
- localDomain domain $ do
- logInfo_ "Initializing ZMQ client"
- env <- ask @env
- mapM_ connect env.subEps
- mapM_ subscribe env.topics
- logTrace_ $ "Listening to " <> pack (show env.subEps)
- logTrace_ $ "Subscribed to " <> pack (show env.topics)
+runClient action =
+ withSocket Z.Sub >>= \sock ->
+ E.evalStaticRep (Client sock) $ do
+ localDomain domain $ do
+ logInfo_ "Initializing ZMQ client"
+ env <- ask @env
+ forM_ env.subEps $ E.unsafeEff_ . Z.connect sock . unpack
+ forM_ env.topics $ E.unsafeEff_ . Z.subscribe sock . encodeUtf8
+ logTrace_ $ "Listening to " <> pack (show env.subEps)
+ logTrace_ $ "Subscribed to " <> pack (show env.topics)
+ action
diff --git a/hsm-core/Hsm/Core/Zmq/Server.hs b/hsm-core/Hsm/Core/Zmq/Server.hs
index 5663cd8..2e9217b 100644
--- a/hsm-core/Hsm/Core/Zmq/Server.hs
+++ b/hsm-core/Hsm/Core/Zmq/Server.hs
@@ -47,7 +47,6 @@ send ::
-> Eff es ()
send = S.fold S.drain . S.mapM sender
where
- sender :: a -> Eff es ()
sender payload = do
Server sock <- E.getStaticRep
env <- ask @env
@@ -64,18 +63,12 @@ runServer ::
)
=> Eff (Server : es) a
-> Eff es a
-runServer action = withSocket Z.Pub >>= run
- where
- run :: Z.Socket Z.Pub -> Eff es a
- run sock = E.evalStaticRep (Server sock) $ initialize >> action
- where
- bind :: Text -> Eff (Server : es) ()
- bind = E.unsafeEff_ . Z.bind sock . unpack
- --
- initialize :: Eff (Server : es) ()
- initialize =
- localDomain domain $ do
- logInfo_ "Initializing ZMQ server"
- env <- ask @env
- bind env.pubEp
- logTrace_ $ "Publishing to " <> env.pubEp
+runServer action =
+ withSocket Z.Pub >>= \sock ->
+ E.evalStaticRep (Server sock) $ do
+ localDomain domain $ do
+ logInfo_ "Initializing ZMQ server"
+ env <- ask @env
+ E.unsafeEff_ $ Z.bind sock $ unpack env.pubEp
+ logTrace_ $ "Publishing to " <> env.pubEp
+ action
diff --git a/hsm-dummy-blinker/Main.hs b/hsm-dummy-blinker/Main.hs
index cfc6654..88b7b5f 100644
--- a/hsm-dummy-blinker/Main.hs
+++ b/hsm-dummy-blinker/Main.hs
@@ -27,30 +27,25 @@ data Env = Env
$(deriveFromYaml ''Env)
stateOn :: F.FsmState () Bool Env Bool
-stateOn = F.FsmState "on" action
- where
- action :: () -> Env -> Bool -> F.FsmOutput () Bool Env Bool
- action _ _ sta =
- F.FsmOutput
- (Just $ F.FsmResult sta False stateOff)
- [(LogInfo, "Turning on blinker")]
+stateOn =
+ F.FsmState "on" $ \_ _ sta ->
+ F.FsmOutput
+ (Just $ F.FsmResult sta False stateOff)
+ [(LogInfo, "Turning on blinker")]
stateOff :: F.FsmState () Bool Env Bool
-stateOff = F.FsmState "off" action
- where
- action :: () -> Env -> Bool -> F.FsmOutput () Bool Env Bool
- action _ _ sta =
- F.FsmOutput
- (Just $ F.FsmResult sta True stateOn)
- [(LogInfo, "Turning off blinker")]
+stateOff =
+ F.FsmState "off" $ \_ _ sta ->
+ F.FsmOutput
+ (Just $ F.FsmResult sta True stateOn)
+ [(LogInfo, "Turning off blinker")]
handle ::
- forall es. (GPIOEffect () :> es, Log :> es, Reader Env :> es)
+ (GPIOEffect () :> es, Log :> es, Reader Env :> es)
=> S.Stream (Eff es) Bool
-> Eff es ()
handle = S.fold S.drain . S.mapM handler
where
- handler :: Bool -> Eff es ()
handler sta = do
env <- ask @Env
toggle sta () [env.period, 0]
diff --git a/hsm-dummy-poller/Main.hs b/hsm-dummy-poller/Main.hs
index 762d139..9f2fad9 100644
--- a/hsm-dummy-poller/Main.hs
+++ b/hsm-dummy-poller/Main.hs
@@ -27,16 +27,13 @@ data Env = Env
$(deriveFromYaml ''Env)
handle ::
- forall es. (Concurrent :> es, Log :> es, Reader Env :> es)
+ (Concurrent :> es, Log :> es, Reader Env :> es)
=> S.Stream (Eff es) [Int]
-> Eff es ()
handle =
S.fold S.drain . S.mapM (\p -> asks period >>= threadDelay >> handler p)
where
- receiverDomain :: Text
receiverDomain = "receiver"
- --
- handler :: [Int] -> Eff es ()
handler [] = localDomain receiverDomain $ logInfo_ "No pulse received yet"
handler ps =
forM_ ps $ \p ->
diff --git a/hsm-dummy-pulser/Main.hs b/hsm-dummy-pulser/Main.hs
index 48a5302..d15b616 100644
--- a/hsm-dummy-pulser/Main.hs
+++ b/hsm-dummy-pulser/Main.hs
@@ -32,19 +32,15 @@ pulse = repeatM $ asks period >>= threadDelay
stateRun :: F.FsmState () Int Env Int
stateRun = F.FsmState "run" action
where
- action :: () -> Env -> Int -> F.FsmOutput () Int Env Int
action _ env sta =
if sta < env.pulses
then next
else exit
where
- next :: F.FsmOutput () Int Env Int
next =
F.FsmOutput
(Just $ F.FsmResult sta (succ sta) stateRun)
[(LogInfo, "Sending pulse #" <> pack (show sta))]
- --
- exit :: F.FsmOutput () Int Env Int
exit =
F.FsmOutput
Nothing
diff --git a/hsm-dummy-receiver/Main.hs b/hsm-dummy-receiver/Main.hs
index 78b343f..451e9c4 100644
--- a/hsm-dummy-receiver/Main.hs
+++ b/hsm-dummy-receiver/Main.hs
@@ -23,15 +23,15 @@ data Env = Env
$(deriveFromYaml ''Env)
-handle ::
- forall es. Log :> es
- => S.Stream (Eff es) Int
- -> Eff es ()
+handle :: Log :> es => S.Stream (Eff es) Int -> Eff es ()
handle = S.fold S.drain . S.mapM handler
where
- handler :: Int -> Eff es ()
- handler p =
- localDomain "receiver" $ logInfo_ $ "Received pulse #" <> pack (show p)
+ handler =
+ localDomain "receiver"
+ . logInfo_
+ . mappend "Received pulse #"
+ . pack
+ . show
-- Dummy receiver service:
-- Proof of concept. Listens for "pulses" through ZMQ and logs each time one
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
index e3deabd..bc08ef5 100644
--- a/hsm-gpio/Hsm/GPIO.hs
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -64,20 +64,12 @@ gpioset state gpios periods = do
localDomain domain $ logTrace_ $ "Calling command: " <> pack command
E.unsafeEff_ $ callCommand command
where
- command :: String
+ lineArg gpio = show gpio <> "=" <> stateStr state <> " "
command =
"gpioset -t"
<> intercalate "," (show <$> periods)
<> " "
<> concatMap lineArg (toList gpios)
- --
- lineArg :: GPIO -> String
- lineArg gpio = show gpio <> "=" <> stateStr state <> " "
-
-getGPIOs :: GPIOEffect key :> es => key -> Eff es (Set GPIO)
-getGPIOs key = do
- GPIOEffect mapper <- E.getStaticRep
- return $ mapper key
logReport ::
(Log :> es, Show key) => Bool -> key -> [Int] -> Set GPIO -> Eff es ()
@@ -85,7 +77,6 @@ logReport state key periods gpios = do
localDomain domain $ logTrace_ report
flushLogger
where
- report :: Text
report =
"Setting pins "
<> pack (show gpios)
@@ -103,29 +94,27 @@ toggle ::
-> [Int]
-> Eff es ()
toggle state key periods = do
- gpios <- getGPIOs key
- logReport state key periods gpios
- gpioset state gpios periods
+ GPIOEffect mapper <- E.getStaticRep
+ set $ mapper key
+ where
+ set gpios = do
+ logReport state key periods gpios
+ gpioset state gpios periods
runGPIO ::
- forall key es a. (IOE :> es, Log :> es, Bounded key, Enum key)
+ (IOE :> es, Log :> es, Bounded key, Enum key)
=> (key -> Set GPIO)
-> Eff (GPIOEffect key : es) a
-> Eff es a
runGPIO mapper action =
- E.evalStaticRep (GPIOEffect mapper) $ finally action releaser
+ E.evalStaticRep (GPIOEffect mapper) $ finally action release
where
- gpios :: Set GPIO
gpios = unions $ mapper <$> [minBound .. maxBound]
- --
- endReport :: Text
endReport =
"Setting all mapped pins "
<> pack (show gpios)
<> " to state "
<> stateStr False
- --
- releaser :: Eff (GPIOEffect key : es) ()
- releaser = do
+ release = do
localDomain domain $ logTrace_ endReport
gpioset False gpios [0]
powered by cgit v1.2.1, back to main portfolio site