Add API type for http monitoring local-cluster

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

@@ -0,0 +1,79 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Cardano.Wallet.Launch.Cluster.Monitoring.Http.API
+    ( API
+    , ApiT (..)
+    )
+where
+
+import Prelude
+
+import Cardano.Wallet.Launch.Cluster.Monitoring.Phase
+    ( History (..)
+    )
+import Control.Monitoring.Tracing
+    ( MonitorState (..)
+    )
+import Data.Aeson
+    ( FromJSON (..)
+    , ToJSON
+    , Value (..)
+    , object
+    , toJSON
+    , withObject
+    , (.:)
+    , (.=)
+    )
+import Servant
+    ( Post
+    , PostNoContent
+    )
+import Servant.API
+    ( Get
+    , JSON
+    , (:<|>)
+    , (:>)
+    )
+
+-- | The API for the monitoring server
+type API =
+    "ready" :> Get '[JSON] Bool
+        :<|> "step" :> PostNoContent
+        :<|> "switch" :> Post '[JSON] (ApiT MonitorState)
+        :<|> "observe" :> Get '[JSON] (ApiT (History, MonitorState))
+
+-- | A newtype wrapper to avoid orphan instances
+newtype ApiT a = ApiT a
+    deriving newtype (Eq, Show)
+
+instance ToJSON (ApiT MonitorState) where
+    toJSON = \case
+        ApiT Wait -> String "waiting"
+        ApiT Step -> String "stepping"
+        ApiT Run -> String "running"
+
+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{history}, state)) =
+        object
+            [ "phases" .= history
+            , "state" .= ApiT state
+            ]
+
+instance FromJSON (ApiT (History, MonitorState)) where
+    parseJSON = withObject "ApiT (History, MonitorState)" $ \o -> do
+        history <- o .: "phases"
+        ApiT state <- o .: "state"
+        pure $ ApiT (History{history}, state)

lib/local-cluster/local-cluster.cabal

@@ -52,6 +52,7 @@ library
     Cardano.Wallet.Launch.Cluster.KeyRegistration
     Cardano.Wallet.Launch.Cluster.Logging
     Cardano.Wallet.Launch.Cluster.MonetaryPolicyScript
+    Cardano.Wallet.Launch.Cluster.Monitoring.Http.API
     Cardano.Wallet.Launch.Cluster.Monitoring.Phase
     Cardano.Wallet.Launch.Cluster.Node.GenNodeConfig
     Cardano.Wallet.Launch.Cluster.Node.GenTopology
@@ -120,8 +121,10 @@ library
     , profunctors
     , resourcet
     , retry
+    , servant
     , servant-client
     , stm
+    , servant-server
     , tagged
     , temporary
     , temporary-extra