aboutsummaryrefslogtreecommitdiff
path: root/hsm-core
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-core')
-rw-r--r--hsm-core/Hsm/Core/App.hs21
-rw-r--r--hsm-core/Hsm/Core/Env.hs26
-rw-r--r--hsm-core/Hsm/Core/Fsm.hs58
-rw-r--r--hsm-core/Hsm/Core/Log.hs27
-rw-r--r--hsm-core/Hsm/Core/Message.hs25
-rw-r--r--hsm-core/Hsm/Core/Options.hs40
-rw-r--r--hsm-core/Hsm/Core/Zmq.hs29
-rw-r--r--hsm-core/Hsm/Core/Zmq/Client.hs93
-rw-r--r--hsm-core/Hsm/Core/Zmq/Server.hs74
-rw-r--r--hsm-core/hsm-core.cabal42
10 files changed, 0 insertions, 435 deletions
diff --git a/hsm-core/Hsm/Core/App.hs b/hsm-core/Hsm/Core/App.hs
deleted file mode 100644
index 11759be..0000000
--- a/hsm-core/Hsm/Core/App.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Hsm.Core.App
- ( launch
- ) where
-
-import Data.Aeson (FromJSON)
-import Data.Text (Text)
-import Effectful.Log (LogLevel, Logger)
-import Hsm.Core.Env (environment)
-import Hsm.Core.Options (Options(Options), options)
-import Log.Backend.StandardOutput (withStdOutLogger)
-
-launch ::
- FromJSON env
- => Text
- -> (IO app -> IO app)
- -> (env -> Logger -> LogLevel -> IO app)
- -> IO app
-launch name wrapper app = do
- Options path level <- options name
- env <- environment name path
- wrapper $ withStdOutLogger $ \logger -> app env logger level
diff --git a/hsm-core/Hsm/Core/Env.hs b/hsm-core/Hsm/Core/Env.hs
deleted file mode 100644
index 8ef7464..0000000
--- a/hsm-core/Hsm/Core/Env.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-module Hsm.Core.Env
- ( environment
- , deriveFromYaml
- ) where
-
-import Data.Aeson (FromJSON, Result(Error, Success), fromJSON)
-import Data.Aeson.Key (fromText)
-import Data.Aeson.KeyMap ((!?))
-import Data.Aeson.TH (defaultOptions, deriveFromJSON, rejectUnknownFields)
-import Data.Maybe (fromMaybe)
-import Data.Text (Text, unpack)
-import Data.Yaml (decodeFileThrow)
-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 =
- fromMaybe
- (error $ "Service configuration for " <> unpack name <> " not found)")
- $ keymap !? fromText name
- check (Success env) = env
- check (Error str) = error str
-
-deriveFromYaml :: Name -> Q [Dec]
-deriveFromYaml = deriveFromJSON defaultOptions {rejectUnknownFields = True}
diff --git a/hsm-core/Hsm/Core/Fsm.hs b/hsm-core/Hsm/Core/Fsm.hs
deleted file mode 100644
index d1c2f5d..0000000
--- a/hsm-core/Hsm/Core/Fsm.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Hsm.Core.Fsm
- ( FsmState(FsmState)
- , FsmOutput(FsmOutput)
- , FsmResult(FsmResult)
- , fsm
- ) where
-
-import Data.Maybe (fromJust, isJust)
-import Data.Text (Text)
-import Effectful (Eff, (:>))
-import Effectful.Log (Log, LogLevel, localDomain, logAttention_, logTrace_)
-import Effectful.Reader.Static (Reader, ask)
-import Effectful.State.Static.Local (State, get, put)
-import Hsm.Core.Log (logTup)
-import Streamly.Data.Stream qualified as S (Stream, mapM, takeWhile)
-
-data FsmState i o env sta =
- FsmState Text (i -> env -> sta -> FsmOutput i o env sta)
-
-data FsmOutput i o env sta =
- FsmOutput (Maybe (FsmResult i o env sta)) [(LogLevel, Text)]
-
-data FsmResult i o env sta =
- FsmResult o sta (FsmState i o env sta)
-
--- Finite state machines allow processing of stream elements using pure
--- functions. One or more FSMs can be included within a `Streamly` pipeline.
-fsm ::
- forall i o env sta es.
- ( Log :> es
- , Reader env :> es
- , State (FsmState i o env sta) :> es
- , State sta :> es
- )
- => S.Stream (Eff es) i
- -> S.Stream (Eff es) o
-fsm = S.mapM (return . fromJust) . S.takeWhile isJust . S.mapM run
- where
- exit = do
- logAttention_ "No state returned, exiting FSM"
- return Nothing
- push (FsmResult out sta next) = do
- put sta
- put next
- return $ Just out
- run input =
- localDomain "fsm" $ do
- FsmState name action <- get
- sta <- get @sta
- env <- ask @env
- logTrace_ $ "Entering state " <> name
- FsmOutput res logs <- return $ action input env sta
- localDomain name $ mapM_ logTup logs
- logTrace_ $ "Exiting state " <> name
- maybe exit push res
diff --git a/hsm-core/Hsm/Core/Log.hs b/hsm-core/Hsm/Core/Log.hs
deleted file mode 100644
index 6930e90..0000000
--- a/hsm-core/Hsm/Core/Log.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-module Hsm.Core.Log
- ( withLogIO
- , logTup
- , flushLogger
- ) where
-
-import Data.Aeson.Types (emptyObject)
-import Data.Text (Text)
-import Data.Time.Clock (getCurrentTime)
-import Effectful (Eff, (:>))
-import Effectful.Dispatch.Static (unsafeEff_)
-import Effectful.Log qualified as L
-
--- Helper function allows logging within IO, Useful during `resourcet`
--- allocation and release operations.
-withLogIO :: L.Log :> es => Eff es (L.LogLevel -> Text -> IO ())
-withLogIO = do
- logIO <- L.getLoggerIO
- return $ \level message -> do
- now <- getCurrentTime
- logIO now level message emptyObject
-
-logTup :: L.Log :> es => (L.LogLevel, Text) -> Eff es ()
-logTup (level, message) = L.logMessage level message emptyObject
-
-flushLogger :: L.Log :> es => Eff es ()
-flushLogger = L.getLoggerEnv >>= unsafeEff_ . L.waitForLogger . L.leLogger
diff --git a/hsm-core/Hsm/Core/Message.hs b/hsm-core/Hsm/Core/Message.hs
deleted file mode 100644
index b2a9f23..0000000
--- a/hsm-core/Hsm/Core/Message.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Hsm.Core.Message
- ( message
- , topic
- , body
- ) where
-
-import Data.Binary (Binary, decode, encode)
-import Data.ByteString (ByteString, fromStrict, toStrict)
-import Data.ByteString.Char8 qualified as B (breakSubstring, drop, length)
-import Data.Text (Text)
-import Data.Text.Encoding (decodeUtf8, encodeUtf8)
-
-sep :: ByteString
-sep = "//"
-
-message :: Binary a => Text -> a -> ByteString
-message t b = encodeUtf8 t <> sep <> toStrict (encode b)
-
-topic :: ByteString -> Text
-topic = decodeUtf8 . fst . B.breakSubstring sep
-
-body :: Binary a => ByteString -> a
-body = decode . fromStrict . B.drop (B.length sep) . snd . B.breakSubstring sep
diff --git a/hsm-core/Hsm/Core/Options.hs b/hsm-core/Hsm/Core/Options.hs
deleted file mode 100644
index 29e40a4..0000000
--- a/hsm-core/Hsm/Core/Options.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Hsm.Core.Options
- ( Options(Options)
- , options
- ) where
-
-import Control.Applicative ((<**>))
-import Data.Text (Text, pack, unpack)
-import Effectful.Log (LogLevel(LogInfo), readLogLevelEither, showLogLevel)
-import Options.Applicative qualified as P
-import Options.Applicative.Text qualified as P
-
-data Options =
- Options Text LogLevel
-
-parser :: P.Parser Options
-parser =
- Options
- <$> P.textOption
- (P.help "Path to services config file"
- <> P.short 'c'
- <> P.long "config"
- <> P.metavar "PATH"
- <> P.value "servconf.yaml"
- <> P.showDefault)
- <*> P.option
- (P.eitherReader $ readLogLevelEither . pack)
- (P.help "Log level"
- <> P.short 'l'
- <> P.long "log-level"
- <> P.metavar "LEVEL"
- <> P.value LogInfo
- <> P.showDefaultWith (unpack . showLogLevel))
-
-options :: Text -> IO Options
-options name =
- P.customExecParser (P.prefs $ P.columns 100)
- $ P.info (parser <**> P.helper)
- $ P.fullDesc <> P.progDesc ("Launch " <> unpack name <> " service")
diff --git a/hsm-core/Hsm/Core/Zmq.hs b/hsm-core/Hsm/Core/Zmq.hs
deleted file mode 100644
index 2f70d48..0000000
--- a/hsm-core/Hsm/Core/Zmq.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Hsm.Core.Zmq
- ( withSocket
- ) where
-
-import Effectful (Eff, IOE, (:>))
-import Effectful.Log (Log, LogLevel(LogTrace))
-import Effectful.Resource (Resource, allocate)
-import Hsm.Core.Log (withLogIO)
-import System.ZMQ4 qualified as Z
-
-withSocket ::
- (Z.SocketType t, IOE :> es, Log :> es, Resource :> es)
- => t
- -> Eff es (Z.Socket t)
-withSocket stype = withLogIO >>= bracket
- where
- bracket logIO = snd . snd <$> allocate acquire release
- where
- 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
deleted file mode 100644
index 6093e54..0000000
--- a/hsm-core/Hsm/Core/Zmq/Client.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Hsm.Core.Zmq.Client
- ( Client
- , receive
- , poll
- , runClient
- ) where
-
-import Control.Monad (forM_)
-import Control.Monad.Loops (whileM)
-import Data.Binary (Binary)
-import Data.Text (Text, pack, unpack)
-import Data.Text.Encoding (encodeUtf8)
-import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
-import Effectful.Dispatch.Static qualified as E
-import Effectful.Log (Log, localDomain, logInfo_, logTrace_)
-import Effectful.Reader.Static (Reader, ask)
-import Effectful.Resource (Resource)
-import GHC.Records (HasField)
-import Hsm.Core.Message (body, topic)
-import Hsm.Core.Zmq (withSocket)
-import Streamly.Data.Stream (Stream, repeatM)
-import System.ZMQ4 qualified as Z
-
-data Client a b
-
-type instance DispatchOf Client = Static E.WithSideEffects
-
-newtype instance E.StaticRep Client =
- Client (Z.Socket Z.Sub)
-
-domain :: Text
-domain = "client"
-
-receiver ::
- forall es a. (Log :> es, Client :> es, Binary a, Show a)
- => Eff es a
-receiver = do
- Client sock <- E.getStaticRep
- message <- E.unsafeEff_ $ Z.receive sock
- localDomain domain
- $ logTrace_
- $ "Message received ["
- <> topic message
- <> "]: "
- <> pack (show $ body @a message)
- return $ body message
-
-receive :: (Log :> es, Client :> es, Binary a, Show a) => Stream (Eff es) a
-receive = repeatM receiver
-
-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 = do
- Client sock <- E.getStaticRep
- peek <- E.unsafeEff_ $ Z.poll 0 [Z.Sock sock [Z.In] Nothing]
- return $ peek /= [[]]
-
-runClient ::
- forall env es a.
- ( HasField "subEps" env [Text]
- , HasField "topics" env [Text]
- , IOE :> es
- , Log :> es
- , Reader env :> es
- , Resource :> es
- )
- => Eff (Client : es) a
- -> Eff es a
-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
deleted file mode 100644
index 2e9217b..0000000
--- a/hsm-core/Hsm/Core/Zmq/Server.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Hsm.Core.Zmq.Server
- ( Server
- , send
- , runServer
- ) where
-
-import Data.Binary (Binary)
-import Data.Text (Text, pack, unpack)
-import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
-import Effectful.Dispatch.Static qualified as E
-import Effectful.Log (Log, localDomain, logInfo_, logTrace_)
-import Effectful.Reader.Static (Reader, ask)
-import Effectful.Resource (Resource)
-import GHC.Records (HasField)
-import Hsm.Core.Message (message)
-import Hsm.Core.Zmq (withSocket)
-import Streamly.Data.Fold qualified as S (drain)
-import Streamly.Data.Stream qualified as S (Stream, fold, mapM)
-import System.ZMQ4 qualified as Z
-
-data Server a b
-
-type instance DispatchOf Server = Static E.WithSideEffects
-
-newtype instance E.StaticRep Server =
- Server (Z.Socket Z.Pub)
-
-domain :: Text
-domain = "server"
-
-send ::
- forall env es a.
- ( HasField "name" env Text
- , Log :> es
- , Reader env :> es
- , Server :> es
- , Binary a
- , Show a
- )
- => S.Stream (Eff es) a
- -> Eff es ()
-send = S.fold S.drain . S.mapM sender
- where
- sender payload = do
- Server sock <- E.getStaticRep
- env <- ask @env
- E.unsafeEff_ $ Z.send sock [] $ message env.name payload
- localDomain domain $ logTrace_ $ "Message sent: " <> pack (show payload)
-
-runServer ::
- forall env es a.
- ( HasField "pubEp" env Text
- , IOE :> es
- , Log :> es
- , Reader env :> es
- , Resource :> es
- )
- => Eff (Server : es) a
- -> Eff es a
-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-core/hsm-core.cabal b/hsm-core/hsm-core.cabal
deleted file mode 100644
index bbdbbb3..0000000
--- a/hsm-core/hsm-core.cabal
+++ /dev/null
@@ -1,42 +0,0 @@
-cabal-version: 3.4
-author: Paul Oliver
-build-type: Simple
-maintainer: contact@pauloliver.dev
-name: hsm-core
-version: 0.1.0.0
-
-library
- build-depends:
- , aeson
- , base
- , binary
- , bytestring
- , effectful-core
- , log-base
- , log-effectful
- , monad-loops
- , optparse-applicative
- , optparse-text
- , resourcet-effectful
- , streamly-core
- , template-haskell
- , text
- , time
- , yaml
- , zeromq4-haskell
-
- exposed-modules:
- Hsm.Core.App
- Hsm.Core.Env
- Hsm.Core.Fsm
- Hsm.Core.Log
- Hsm.Core.Message
- Hsm.Core.Zmq.Client
- Hsm.Core.Zmq.Server
-
- other-modules:
- Hsm.Core.Options
- Hsm.Core.Zmq
-
- ghc-options: -Wall -Wunused-packages
- default-language: GHC2021
powered by cgit v1.2.1, back to main portfolio site