Extract control api component of the local-cluster http service

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

@@ -2,141 +2,25 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Wallet.Launch.Cluster.Monitoring.Http.API
     ( API
-    , ApiT (..)
-    , ReadyAPI
-    , StepAPI
-    , SwitchAPI
-    , ObserveAPI
     , ControlAPI
     )
 where
 
-import Prelude
-
 import Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.API
     ( ApplicationAPI
     )
-import Cardano.Wallet.Launch.Cluster.Monitoring.Http.OpenApi
-    ( monitorStateSchema
-    , observationSchema
-    )
-import Cardano.Wallet.Launch.Cluster.Monitoring.Phase
-    ( History (..)
-    )
-import Control.Monitoring.Tracing
-    ( MonitorState (..)
-    )
-import Data.Aeson.Types
-    ( FromJSON (..)
-    , Parser
-    , ToJSON (..)
-    , Value (..)
-    , object
-    , withArray
-    , withObject
-    , (.:)
-    , (.=)
-    )
-import Data.Foldable
-    ( toList
-    )
-import Data.OpenApi
-    ( NamedSchema (..)
-    , ToSchema (..)
-    )
-import GHC.Generics
-    ( Generic (..)
-    )
-import Servant
-    ( Post
-    , PostNoContent
+import Cardano.Wallet.Launch.Cluster.Monitoring.Http.Control.API
+    ( ControlAPI
     )
 import Servant.API
-    ( Get
-    , JSON
-    , (:<|>)
-    , (:>)
+    ( (:<|>)
     )
 
-type ReadyAPI = "ready" :> Get '[JSON] Bool
-type StepAPI = "control" :> "step" :> PostNoContent
-type SwitchAPI = "control" :> "switch" :> Post '[JSON] (ApiT MonitorState)
-type ObserveAPI = "control" :> "observe" :> Get '[JSON] (ApiT (History, MonitorState))
-
--- | The API to control the monitoring server
-type ControlAPI = ReadyAPI :<|> StepAPI :<|> SwitchAPI :<|> ObserveAPI
-
 -- | The API for the monitoring server and the query cluster application
 type API n = ControlAPI :<|> ApplicationAPI n
-
--- | A newtype wrapper to avoid orphan instances
-newtype ApiT a = ApiT {unApiT :: a}
-    deriving newtype (Eq, Show, Generic)
-
-renderHistory :: History -> Value
-renderHistory History{history} = toJSON $ do
-    (time, phase) <- history
-    pure
-        $ object
-            [ "time" .= time
-            , "phase" .= phase
-            ]
-
-parseHistory :: Value -> Parser History
-parseHistory = withArray "History" $ \arr -> do
-    history <- traverse parsePhase (toList arr)
-    pure $ History{history}
-  where
-    parsePhase = withObject "Phase" $ \o -> do
-        time <- o .: "time"
-        phase <- o .: "phase"
-        pure (time, phase)
-
-instance ToJSON (ApiT MonitorState) where
-    toJSON = \case
-        ApiT Wait -> String "waiting"
-        ApiT Step -> String "stepping"
-        ApiT Run -> String "running"
-
-instance ToSchema (ApiT MonitorState) where
-    declareNamedSchema _ = do
-        pure
-            $ NamedSchema
-                (Just "ApiT MonitorState")
-                monitorStateSchema
-
-instance FromJSON (ApiT MonitorState) where
-    parseJSON = \case
-        String "waiting" -> pure $ ApiT Wait
-        String "stepping" -> pure $ ApiT Step
-        String "running" -> pure $ ApiT Run
-        _ -> fail "Invalid state"
-
-instance ToJSON (ApiT (History, MonitorState)) where
-    toJSON (ApiT (history, state)) =
-        object
-            [ "phases" .= renderHistory history
-            , "state" .= ApiT state
-            ]
-
-instance ToSchema (ApiT (History, MonitorState)) where
-    declareNamedSchema _ =
-        pure
-            $ NamedSchema
-                (Just "ApiT (History, MonitorState)")
-                observationSchema
-
-instance FromJSON (ApiT (History, MonitorState)) where
-    parseJSON = withObject "ApiT (History, MonitorState)" $ \o -> do
-        history <- o .: "phases" >>= parseHistory
-        ApiT state <- o .: "state"
-        pure $ ApiT (history, state)

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

@@ -0,0 +1,17 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Cardano.Wallet.Launch.Cluster.Monitoring.Http.ApiT
+    ( ApiT (..)
+    )
+where
+
+import Prelude
+
+import GHC.Generics
+    ( Generic
+    )
+
+-- | A newtype wrapper to avoid orphan instances
+newtype ApiT a = ApiT {unApiT :: a}
+    deriving newtype (Eq, Show, Generic)

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -11,6 +12,7 @@ module Cardano.Wallet.Launch.Cluster.Monitoring.Http.Application.Client
     , AnyApplicationQ (..)
     , RunApplicationQ (..)
     , Application
+    , MsgApplication (..)
     )
 where
 
@@ -40,6 +42,9 @@ import Data.Data
 import Data.Functor
     ( ($>)
     )
+import Data.Text.Class
+    ( ToText (..)
+    )
 import Servant
     ( NoContent
     )
@@ -73,6 +78,12 @@ mkApplication _ =
         { sendFaucetAssets = client (Proxy @(SendFaucetAssetsAPI n))
         }
 
+newtype MsgApplication = MsgApplicationRequest AnyApplicationQ
+    deriving stock (Show)
+
+instance ToText MsgApplication where
+    toText (MsgApplicationRequest q) = toText $ show q
+
 -- | Run any query against the monitoring server.
 newtype RunApplicationQ m
     = RunApplicationQ (forall a. Show a => ApplicationQ a -> m a)
@@ -81,13 +92,13 @@ newtype RunApplicationQ m
 newApplicationQ
     :: MonadUnliftIO m
     => (forall a. ClientM a -> IO a)
-    -> Tracer m AnyApplicationQ
+    -> Tracer m MsgApplication
     -> Application n
     -> m (RunApplicationQ m)
 newApplicationQ query tr Application{..} = pure
     $ RunApplicationQ
     $ \request -> do
-        traceWith tr (AnyApplicationQ request)
+        traceWith tr (MsgApplicationRequest $ AnyApplicationQ request)
         case request of
             SendFaucetAssetsQ assets ->
                 liftIO