Node API Documentation Server

lib/cardano-sl.cabal

@@ -116,6 +116,7 @@ library
                         Test.Pos.Configuration
 
                         Pos.Util.Servant
+                        Pos.Util.Swagger
                         Pos.Util.Jsend
                         Pos.Util.UnitsOfMeasure
                         Pos.Util.Pagination
@@ -202,6 +203,9 @@ library
                       , servant-client-core >= 0.8.1
                       , servant-server >= 0.8.1
                       , servant-swagger
+                      , servant-swagger-ui
+                      , servant-swagger-ui-core
+                      , servant-swagger-ui-redoc
                       , stm
                       , streaming-commons
                       , swagger2

lib/src/Pos/Client/CLI/NodeOptions.hs

@@ -173,17 +173,18 @@ nodeWithApiArgsParser =
 nodeApiArgsParser :: Parser NodeApiArgs
 nodeApiArgsParser =
     NodeApiArgs
-        <$> addressParser
+        <$> addressParser "node-api-address" (localhost, 8083)
         <*> tlsParamsParser
         <*> debugModeParser
+        <*> addressParser "node-doc-address" (localhost, 8084)
   where
-    addressParser =
+    addressParser flagName defValue =
         option (fromParsec addrParser) $
-            long "node-api-address"
+            long flagName
          <> metavar "IP:PORT"
          <> help helpMsg
          <> showDefault
-         <> value (localhost, 8083)
+         <> value defValue
     helpMsg = "IP and port for backend node API."
     debugModeParser :: Parser Bool
     debugModeParser =
@@ -196,6 +197,7 @@ data NodeApiArgs = NodeApiArgs
     { nodeBackendAddress   :: !NetworkAddress
     , nodeBackendTLSParams :: !(Maybe TlsParams)
     , nodeBackendDebugMode :: !Bool
+    , nodeBackendDocAddress :: !NetworkAddress
     } deriving Show
 
 tlsParamsParser :: Parser (Maybe TlsParams)

lib/src/Pos/Node/API.hs

@@ -43,7 +43,7 @@ import           Pos.Infra.Util.LogSafe (BuildableSafeGen (..), SecureLog (..),
                      deriveSafeBuildable)
 import           Pos.Util.Example
 import           Pos.Util.Servant (APIResponse, CustomQueryFlag, Flaggable (..),
-                     Tags, ValidJSON)
+                     Tags, ValidJSON, HasCustomQueryFlagDescription(..))
 import           Pos.Util.UnitsOfMeasure
 import           Serokell.Util.Text
 
@@ -107,6 +107,10 @@ instance BuildableSafeGen ForceNtpCheck where
     buildSafeGen _ ForceNtpCheck = "force ntp check"
     buildSafeGen _ NoNtpCheck    = "no ntp check"
 
+forceNtpCheckDescription :: T.Text
+forceNtpCheckDescription =
+    "In some cases, API Clients need to force a new NTP check as a previous result gets cached. A typical use-case is after asking a user to fix its system clock. If this flag is set, request will block until NTP server responds or it will timout if NTP server is not available within **30** seconds."
+
 
 -- | The different between the local time and the remote NTP server.
 newtype LocalTimeDifference = LocalTimeDifference (MeasuredIn 'Microseconds Integer)
@@ -599,6 +603,9 @@ type InfoAPI =
             :> CustomQueryFlag "force_ntp_check" ForceNtpCheck
             :> Get '[ValidJSON] (APIResponse NodeInfo)
 
+instance HasCustomQueryFlagDescription "force_ntp_check" where
+    customDescription _ = Just forceNtpCheckDescription
+
 -- The API definition is down here for now due to TH staging restrictions. Will
 -- relocate other stuff into it's own module when the extraction is complete.
 type API =

lib/src/Pos/Util/Servant.hs

@@ -60,6 +60,7 @@ module Pos.Util.Servant
 
     , Flaggable (..)
     , CustomQueryFlag
+    , HasCustomQueryFlagDescription(..)
 
     , serverHandlerL
     , serverHandlerL'
@@ -80,7 +81,7 @@ module Pos.Util.Servant
 import           Universum
 
 import           Control.Exception.Safe (handleAny)
-import           Control.Lens (Iso, iso, ix, makePrisms)
+import           Control.Lens (Iso, iso, ix, makePrisms, (?~))
 import           Control.Monad.Except (ExceptT (..), MonadError (..))
 import           Data.Aeson (FromJSON (..), ToJSON (..), eitherDecode, encode,
                      object, (.=))
@@ -118,7 +119,8 @@ import           Servant.Client.Core (RunClient)
 import           Servant.Server (Handler (..), HasServer (..), ServantErr (..),
                      Server)
 import qualified Servant.Server.Internal as SI
-import           Servant.Swagger (HasSwagger (toSwagger))
+import           Servant.Swagger
+import           Servant.Swagger.Internal
 import           Test.QuickCheck
 
 import           Pos.Infra.Util.LogSafe (BuildableSafe, SecuredText, buildSafe,
@@ -762,6 +764,30 @@ instance ReportDecodeError api =>
 -- Boolean type for all flags but we can implement custom type.
 data CustomQueryFlag (sym :: Symbol) flag
 
+instance
+    ( KnownSymbol sym
+    , HasSwagger sub
+    , HasCustomQueryFlagDescription sym
+    ) => HasSwagger (CustomQueryFlag sym flag :> sub)
+  where
+    toSwagger _ = toSwagger (Proxy :: Proxy sub)
+        & addParam param
+        & addDefaultResponse400 tname
+      where
+        tname = T.pack (symbolVal (Proxy :: Proxy sym))
+        param = mempty
+            & name .~ tname
+            & description .~ customDescription (Proxy @sym)
+            & schema .~ ParamOther (mempty
+                & in_ .~ ParamQuery
+                & allowEmptyValue ?~ True
+                & paramSchema .~ (toParamSchema (Proxy :: Proxy Bool)
+                    & default_ ?~ toJSON False))
+
+class HasCustomQueryFlagDescription (sym :: Symbol) where
+    customDescription :: Proxy sym -> Maybe Text
+    customDescription _ = Nothing
+
 class Flaggable flag where
     toBool :: flag -> Bool
     fromBool :: Bool -> flag
@@ -770,7 +796,6 @@ instance Flaggable Bool where
     toBool = identity
     fromBool = identity
 
--- TODO (akegalj): this instance is almost the same as upstream HasServer instance of QueryFlag. The only difference is addition of `fromBool` function in `route` implementation. Can we somehow reuse `route` implementation of CustomQuery instead of copy-pasting it here with this small `fromBool` addition?
 instance (KnownSymbol sym, HasServer api context, Flaggable flag)
     => HasServer (CustomQueryFlag sym flag :> api) context where
 

lib/src/Pos/Util/Swagger.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Pos.Util.Swagger where
+
+import           Universum
+
+import           Data.Swagger
+import           NeatInterpolation (text)
+import           Servant.Server (Handler, Server)
+import           Servant.Swagger.UI.Core (SwaggerSchemaUI',
+                     swaggerSchemaUIServerImpl)
+import           Servant.Swagger.UI.ReDoc (redocFiles)
+
+-- | Provide an alternative UI (ReDoc) for rendering Swagger documentation.
+swaggerSchemaUIServer
+    :: (Server api ~ Handler Swagger)
+    => Swagger -> Server (SwaggerSchemaUI' dir api)
+swaggerSchemaUIServer =
+    swaggerSchemaUIServerImpl redocIndexTemplate redocFiles
+  where
+    redocIndexTemplate :: Text
+    redocIndexTemplate = [text|
+<!doctype html>
+<html lang="en">
+  <head>
+    <title>ReDoc</title>
+    <meta charset="utf-8"/>
+    <meta name="viewport" content="width=device-width, initial-scale=1">
+    <style>
+      body { margin: 0; padding: 0; }
+    </style>
+    <script>
+        // Force Strict-URL Routing for assets relative paths
+        (function onload() {
+            if (!window.location.href.endsWith("/")) {
+                window.location.href += "/";
+            }
+        }());
+    </script>
+  </head>
+  <body>
+    <redoc spec-url="../SERVANT_SWAGGER_UI_SCHEMA"></redoc>
+    <script src="redoc.min.js"> </script>
+  </body>
+</html>|]
+

node/cardano-sl-node.cabal

@@ -18,6 +18,7 @@ library
   hs-source-dirs:      src
   build-depends:       base
                      , aeson
+                     , async
                      , bytestring
                      , cardano-sl
                      , cardano-sl-chain
@@ -31,14 +32,18 @@ library
                      , http-types
                      , lens
                      , servant-server
+                     , servant-swagger
+                     , servant-swagger-ui
                      , stm
+                     , swagger2
                      , text
                      , time-units
                      , universum
                      , wai
                      , warp
 
   exposed-modules:     Cardano.Node.API
+                       Cardano.Node.API.Swagger
 
   other-modules:       Paths_cardano_sl_node
 

node/src/Cardano/Node/API.hs

@@ -7,6 +7,7 @@ module Cardano.Node.API where
 
 import           Universum
 
+import           Control.Concurrent.Async (concurrently_)
 import           Control.Concurrent.STM (orElse, retry)
 import           Control.Lens (lens, makeLensesWith, to)
 import           Data.Aeson (encode)
@@ -51,6 +52,8 @@ import           Pos.Util.Servant (APIResponse (..), JsendException (..),
 import           Pos.Web (serveImpl)
 import qualified Pos.Web as Legacy
 
+import Cardano.Node.API.Swagger (forkDocServer)
+
 type NodeV1Api
     = "v1"
     :> ( Node.API
@@ -146,14 +149,25 @@ launchNodeServer
                 compileTimeInfo
             :<|> legacyApi
 
-    serveImpl
-        (pure app)
-        (BS8.unpack ipAddress)
-        portNumber
-        (do guard (not isDebug)
-            nodeBackendTLSParams params)
-        (Just exceptionResponse)
-        Nothing -- TODO: Set a port callback for shutdown/IPC
+    concurrently_
+        (serveImpl
+            (pure app)
+            (BS8.unpack ipAddress)
+            portNumber
+            (do guard (not isDebug)
+                nodeBackendTLSParams params)
+            (Just exceptionResponse)
+            Nothing -- TODO: Set a port callback for shutdown/IPC
+            )
+        (forkDocServer
+            (Proxy @NodeV1Api)
+            (curSoftwareVersion updateConfiguration)
+            (BS8.unpack docAddress)
+            docPort
+            (do guard (not isDebug)
+                nodeBackendTLSParams params)
+
+        )
   where
     isDebug = nodeBackendDebugMode params
     exceptionResponse =
@@ -167,6 +181,7 @@ launchNodeServer
     nodeCtx = nrContext nodeResources
     (slottingVarTimestamp, slottingVar) = ncSlottingVar nodeCtx
     (ipAddress, portNumber) = nodeBackendAddress params
+    (docAddress, docPort) = nodeBackendDocAddress params
 
 handlers
     :: Diffusion IO

node/src/Cardano/Node/API/Swagger.hs

@@ -0,0 +1,77 @@
+-- necessary for `ToParamSchema Core.EpochIndex`
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Cardano.Node.API.Swagger where
+
+import           Universum
+
+import           Control.Lens ((?~), at)
+import           Data.Swagger
+import           Servant
+import           Servant.Swagger
+import           Servant.Swagger.UI (SwaggerSchemaUI)
+
+import Pos.Chain.Txp (TxIn, TxOutAux, TxOut)
+import           Pos.Chain.Update (SoftwareVersion)
+import           Pos.Util.Swagger (swaggerSchemaUIServer)
+import           Pos.Web (serveDocImpl, CConfirmedProposalState)
+import           Pos.Web.Types (TlsParams)
+
+forkDocServer
+    :: HasSwagger a
+    => Proxy a
+    -> SoftwareVersion
+    -> String
+    -> Word16
+    -> Maybe TlsParams
+    -> IO ()
+forkDocServer prxy swVersion ip port' tlsParams =
+    serveDocImpl
+        (pure app)
+        ip
+        port'
+        tlsParams
+        Nothing
+        Nothing
+  where
+    app =
+        serve
+            (Proxy @("docs" :> "v1" :> SwaggerSchemaUI "index" "swagger.json"))
+            (swaggerSchemaUIServer (documentationApi swVersion prxy))
+
+documentationApi
+    :: HasSwagger a
+    => SoftwareVersion
+    -> Proxy a
+    -> Swagger
+documentationApi curSoftwareVersion prxy = toSwagger prxy
+    & info.title   .~ "Cardano Node API"
+    & info.version .~ fromString (show curSoftwareVersion)
+    & host ?~ "127.0.0.1:8083"
+    & info.license ?~ ("MIT" & url ?~ URL "https://raw.githubusercontent.com/input-output-hk/cardano-sl/develop/lib/LICENSE")
+
+instance ToParamSchema TxIn where
+    toParamSchema _ = mempty
+        & type_ .~ SwaggerString
+
+instance ToSchema TxIn where
+    declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
+
+instance ToSchema TxOut where
+    declareNamedSchema _ =
+        pure $ NamedSchema (Just "TxOut") $ mempty
+            & type_ .~ SwaggerObject
+            & required .~ ["coin", "address"]
+            & properties .~ (mempty
+                & at "coin" ?~ (Inline $ mempty
+                    & type_ .~ SwaggerNumber
+                    )
+                & at "address" ?~ (Inline $ mempty
+                    & type_ .~ SwaggerString
+                    )
+                )
+
+instance ToSchema TxOutAux
+
+instance ToSchema CConfirmedProposalState
+