Rename Monitoring.Http hierarchy to Http.Monitor

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wno-missing-local-signatures #-}
+
+module Cardano.Wallet.Launch.Cluster.Http
+    ( MsgHttpMonitoring (..)
+    , MonitorConfiguration (..)
+    , withMonitoring
+    )
+where
+
+import Prelude
+
+import Cardano.Wallet.Launch.Cluster.Http.Monitor.Client
+    ( RunQuery
+    , withHttpClient
+    )
+import Cardano.Wallet.Launch.Cluster.Http.Monitor.Logging
+    ( MsgHttpMonitoring (..)
+    )
+import Cardano.Wallet.Launch.Cluster.Http.Monitor.Server
+    ( mkHandlers
+    , withHttpServer
+    )
+import Cardano.Wallet.Launch.Cluster.Monitoring.Phase
+    ( History (..)
+    , Phase
+    )
+import Cardano.Wallet.Network.Ports
+    ( getRandomPort
+    )
+import Control.Concurrent.Class.MonadSTM
+    ( MonadSTM
+    )
+import Control.Monad.Cont
+    ( ContT (..)
+    )
+import Control.Monad.IO.Class
+    ( MonadIO (..)
+    )
+import Control.Monitoring.Folder
+import Control.Monitoring.Monitor
+    ( Monitor
+    , mkMonitor
+    , monitorTracer
+    )
+import Control.Monitoring.Tracing
+    ( AnyTracing (AnyTracing)
+    , MonitorState
+    , StateS (..)
+    , Tracing
+    , withTracingState
+    )
+import Control.Tracer
+    ( Tracer (..)
+    , traceWith
+    )
+import Data.Functor.Contravariant
+    ( (>$<)
+    )
+import Data.Profunctor
+    ( Profunctor (..)
+    )
+import Data.Time
+    ( UTCTime
+    , getCurrentTime
+    )
+import Network.Socket
+    ( PortNumber
+    )
+
+import qualified Control.Foldl as F
+
+-- | Configuration for the monitoring service
+data MonitorConfiguration = MonitorConfiguration
+    { monitorPort :: Maybe PortNumber
+    -- ^ The port to run the monitoring service on
+    -- If `Nothing`, a random port will be chosen
+    , monitorInitialState :: MonitorState
+    -- ^ The initial state of the monitor
+    }
+    deriving stock (Show)
+
+timedMonitor
+    :: forall m w a
+     . (MonadSTM m, MonadIO m)
+    => StateS w
+    -> m (Monitor m a [(UTCTime,a)])
+timedMonitor initialState = do
+    let tracer :: Tracing w (UTCTime, a) [(UTCTime,a)]
+        tracer = mkTracingFromFold F.list initialState
+    mkMonitor
+        (AnyTracing initialState tracer)
+        (\x -> (,x) <$> liftIO getCurrentTime)
+
+-- | Start a monitoring service, returning a tracer to write `Phase` values to
+-- and a function to interact with the monitoring service
+withMonitoring
+    :: Tracer IO MsgHttpMonitoring
+    -- ^ Tracer for logging the monitoring operations
+    -> MonitorConfiguration
+    -- ^ Configuration for the monitoring service
+    -> ContT () IO (Tracer IO Phase, RunQuery IO)
+withMonitoring tr MonitorConfiguration{..} = do
+    monitor <- liftIO $ withTracingState timedMonitor monitorInitialState
+    port <- liftIO $ maybe getRandomPort pure monitorPort
+    liftIO $ traceWith tr $ MsgHttpMonitoringPort port
+    withHttpServer port $ mkHandlers $ rmap History monitor
+    liftIO $ traceWith tr MsgHttpMonitoringServerStarted
+    runQueries <- withHttpClient (MsgHttpMonitoringQuery >$< tr) port
+    ContT $ \k -> do
+        k (monitorTracer monitor, runQueries)
+        traceWith tr MsgHttpMonitoringDone

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/API.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeOperators #-}
+
+module Cardano.Wallet.Launch.Cluster.Http.API
+    ( API
+    )
+where
+
+import Cardano.Wallet.Launch.Cluster.Http.Faucet.API
+    ( FaucetAPI
+    )
+import Cardano.Wallet.Launch.Cluster.Http.Monitor.API
+    ( ControlAPI
+    )
+import Servant.API
+    ( (:<|>)
+    )
+
+-- | The API for the monitoring server and the query cluster application
+type API n = ControlAPI :<|> FaucetAPI n

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Client.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Wallet.Launch.Cluster.Http.Client
+    ( withHttpClient
+    , MsgClient (..)
+    )
+where
+
+import Prelude
+
+import Cardano.Wallet.Launch.Cluster.Http.Faucet.Client
+    ( MsgFaucetClient
+    , RunFaucetQ
+    , mkFaucet
+    , newFaucetQ
+    )
+import Cardano.Wallet.Launch.Cluster.Http.Monitor.Client
+    ( MsgMonitorClient
+    , RunMonitorQ
+    , mkMonitorClient
+    , newRunQuery
+    )
+import Cardano.Wallet.Primitive.NetworkId
+    ( HasSNetworkId
+    , SNetworkId
+    )
+import Control.Monad.Cont
+    ( ContT (..)
+    )
+import Control.Monad.IO.Class
+    ( liftIO
+    )
+import Control.Tracer
+    ( Tracer
+    , traceWith
+    )
+import Data.Functor.Contravariant
+    ( (>$<)
+    )
+import Data.Text.Class
+    ( ToText (..)
+    )
+import Network.HTTP.Client
+    ( ManagerSettings (..)
+    , defaultManagerSettings
+    , newManager
+    , responseTimeoutNone
+    )
+import Network.Socket
+    ( PortNumber
+    )
+import Servant.Client
+    ( BaseUrl (..)
+    , ClientM
+    , Scheme (..)
+    , mkClientEnv
+    , runClientM
+    )
+import UnliftIO
+    ( MonadUnliftIO
+    , throwIO
+    )
+
+data MsgClient
+    = MsgClientStart
+    | MsgClientDone
+    | MsgMonitorClient MsgMonitorClient
+    | MsgFaucetClient MsgFaucetClient
+    deriving stock (Show)
+
+instance ToText MsgClient where
+    toText = \case
+        MsgClientStart -> "HTTP client started"
+        MsgClientDone -> "HTTP client done"
+        MsgMonitorClient msg -> toText msg
+        MsgFaucetClient msg -> toText msg
+
+-- | Produce a closure over the http client of an http monitoring server that
+-- can be used to query the server.
+withHttpClient
+    :: (MonadUnliftIO m, HasSNetworkId n)
+    => SNetworkId n
+    -> Tracer m MsgClient
+    -- ^ how to trace the http client operations
+    -> PortNumber
+    -- ^ Monitoring port to attach to (http://localhost is hardcoded)
+    -> ContT () m (RunMonitorQ m, RunFaucetQ m)
+withHttpClient networkId tracer httpPort = ContT $ \continue -> do
+    let tr = traceWith tracer
+    tr MsgClientStart
+    let url = BaseUrl Http "localhost" (fromIntegral httpPort) ""
+    manager <-
+        liftIO
+            $ newManager
+            $ defaultManagerSettings
+                { managerResponseTimeout = responseTimeoutNone
+                }
+    let
+        query :: ClientM a -> IO a
+        query f = do
+            r <- runClientM f $ mkClientEnv manager url
+            either throwIO pure r
+    runQuery <- newRunQuery query (MsgMonitorClient >$< tracer) mkMonitorClient
+    runFaucet <-
+        newFaucetQ
+            query
+            (MsgFaucetClient >$< tracer)
+            $ mkFaucet networkId
+    continue (runQuery, runFaucet)
+
+    tr MsgClientDone

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Faucet/API.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Cardano.Wallet.Launch.Cluster.Http.Faucet.API
+    ( FaucetAPI
+    , SendFaucetAssetsAPI
+    )
+where
+
+import Cardano.Wallet.Launch.Cluster.Http.Faucet.SendFaucetAssets
+    ( SendFaucetAssets
+    , WithNetwork (..)
+    )
+import Servant
+    ( JSON
+    , PostNoContent
+    , ReqBody
+    , (:>)
+    )
+
+type SendFaucetAssetsAPI n =
+    "send"
+        :> "faucet-assets"
+        :> ReqBody '[JSON] (WithNetwork SendFaucetAssets n)
+        :> PostNoContent
+
+type FaucetAPI n = SendFaucetAssetsAPI n

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster/Http/Faucet/Client.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Cardano.Wallet.Launch.Cluster.Http.Faucet.Client
+    ( newFaucetQ
+    , mkFaucet
+    , FaucetQ (..)
+    , AnyFaucetQ (..)
+    , RunFaucetQ (..)
+    , Faucet
+    , MsgFaucetClient (..)
+    )
+where
+
+import Prelude
+
+import Cardano.Wallet.Launch.Cluster.Http.Faucet.API
+    ( SendFaucetAssetsAPI
+    )
+import Cardano.Wallet.Launch.Cluster.Http.Faucet.SendFaucetAssets
+    ( SendFaucetAssets
+    , WithNetwork (..)
+    )
+import Cardano.Wallet.Primitive.NetworkId
+    ( HasSNetworkId
+    , SNetworkId
+    )
+import Control.Monad.IO.Class
+    ( MonadIO (..)
+    )
+import Control.Tracer
+    ( Tracer
+    , traceWith
+    )
+import Data.Data
+    ( Proxy (Proxy)
+    )
+import Data.Functor
+    ( ($>)
+    )
+import Data.Text.Class
+    ( ToText (..)
+    )
+import Servant
+    ( NoContent
+    )
+import Servant.Client
+    ( ClientM
+    , client
+    )
+import UnliftIO
+    ( MonadUnliftIO
+    )
+
+-- | Queries that can be run against the local cluster
+data FaucetQ a where
+    SendFaucetAssetsQ :: SendFaucetAssets -> FaucetQ ()
+
+-- | Existential wrapper for any application query that has a show instance
+data AnyFaucetQ = forall a. Show a => AnyFaucetQ (FaucetQ a)
+
+instance Show AnyFaucetQ where
+    show (AnyFaucetQ (SendFaucetAssetsQ _)) = "SendFaucetAssets"
+
+-- | Opaque record of the client application
+newtype Faucet n = Faucet
+    { sendFaucetAssets :: WithNetwork SendFaucetAssets n -> ClientM NoContent
+    }
+
+-- | Construct the client application given the network id witness
+mkFaucet :: forall n. HasSNetworkId n => SNetworkId n -> Faucet n
+mkFaucet _ =
+    Faucet
+        { sendFaucetAssets = client (Proxy @(SendFaucetAssetsAPI n))
+        }
+
+newtype MsgFaucetClient = MsgFaucetRequest AnyFaucetQ
+    deriving stock Show
+
+instance ToText MsgFaucetClient where
+    toText (MsgFaucetRequest q) = "Faucet request: " <> toText (show q)
+
+-- | Run any query against the monitoring server.
+newtype RunFaucetQ m
+    = RunFaucetQ (forall a. Show a => FaucetQ a -> m a)
+
+-- | Construct the run function for the client application
+newFaucetQ
+    :: MonadUnliftIO m
+    => (forall a. ClientM a -> IO a)
+    -> Tracer m MsgFaucetClient
+    -> Faucet n
+    -> m (RunFaucetQ m)
+newFaucetQ query tr Faucet{..} = pure
+    $ RunFaucetQ
+    $ \request -> do
+        traceWith tr (MsgFaucetRequest $ AnyFaucetQ request)
+        case request of
+            SendFaucetAssetsQ assets ->
+                liftIO
+                    $ query
+                    $ sendFaucetAssets (WithNetwork assets) $> ()