Merge #3957

3957: Implement Update endpoints for the Node API r=parsonsmatt a=parsonsmatt

## Description

This PR implements the node update endpoints.

## Linked issue

There's a change to the implementation of the API. The decision is covered here:
cardano-foundation/cardano-wallet#151



Co-authored-by: parsonsmatt <parsonsmatt@gmail.com>

cluster/src/Cardano/Cluster.hs

@@ -25,6 +25,7 @@ import           Control.Lens (at)
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import           Options.Applicative (handleParseResult, info)
+import           Servant.Client (ServantError (..))
 import           System.Environment (getEnvironment)
 
 import           Cardano.Cluster.Environment (Artifact (..), Env,
@@ -177,7 +178,7 @@ waitForNode client (MaxWaitingTime s) reportProgress = do
             when (progress < mkSyncPercentage 100) $
                 reportProgress (Just progress) >> retry
 
-        Left ConnectionError{} ->
+        Left (ErrFromServant ConnectionError{}) ->
             reportProgress Nothing >> retry
 
         Left err ->

lib/src/Pos/Node/API.hs

@@ -613,11 +613,10 @@ type API =
     :<|>
         InfoAPI
     :<|>
-        "update"
-            :> ( "apply"
-                :> Summary "Apply the next available update"
-                :> Post '[ValidJSON] NoContent
-            :<|> "postpone"
-                :> Summary "Discard and postpone the next available update"
-                :> Post '[ValidJSON] NoContent
-            )
+        Summary "Version of the next update (404 if none)"
+        :> "next-update"
+        :> Get '[ValidJSON] (APIResponse (V1 Core.SoftwareVersion))
+    :<|>
+        Summary "Restart the underlying node software."
+        :> "restart-node"
+        :> Post '[ValidJSON] NoContent

node/src/Cardano/Node/API.hs

@@ -25,7 +25,9 @@ import           Ntp.Client (NtpConfiguration, NtpStatus (..),
 import           Ntp.Packet (NtpOffset)
 import           Pos.Chain.Block (LastKnownHeader, LastKnownHeaderTag)
 import           Pos.Chain.Ssc (SscContext)
-import           Pos.Chain.Update (UpdateConfiguration, curSoftwareVersion)
+import           Pos.Chain.Update (ConfirmedProposalState (..), SoftwareVersion,
+                     UpdateConfiguration, UpdateProposal (..),
+                     curSoftwareVersion)
 import           Pos.Client.CLI.NodeOptions (NodeApiArgs (..))
 import           Pos.Context (HasPrimaryKey (..), HasSscContext (..),
                      NodeContext (..))
@@ -38,6 +40,7 @@ import           Pos.DB.GState.Lock (Priority (..), StateLock,
                      withStateLockNoMetrics)
 import qualified Pos.DB.Rocks as DB
 import           Pos.DB.Txp.MemState (GenericTxpLocalData, TxpHolderTag)
+import           Pos.DB.Update (UpdateContext (..))
 import           Pos.Infra.Diffusion.Subscription.Status (ssMap)
 import           Pos.Infra.Diffusion.Types (Diffusion (..))
 import           Pos.Infra.InjectFail (FInject (..), testLogFInject)
@@ -64,6 +67,10 @@ type NodeV1Api
 nodeV1Api :: Proxy NodeV1Api
 nodeV1Api = Proxy
 
+--------------------------------------------------------------------------------
+-- Legacy Handlers
+--------------------------------------------------------------------------------
+
 data LegacyCtx = LegacyCtx
     { legacyCtxTxpLocalData
         :: !(GenericTxpLocalData ())
@@ -101,13 +108,22 @@ instance {-# OVERLAPPING #-} DB.MonadDBRead (ReaderT LegacyCtx IO) where
     dbGetSerUndo = DB.dbGetSerUndoRealDefault
     dbGetSerBlund = DB.dbGetSerBlundRealDefault
 
+-- | Prepare a 'Server' for the 'Legacy.NodeApi'. We expose a 'Server' so that
+-- it can be embedded in other APIs, instead of an 'Application', which can only
+-- be run on a given port.
 legacyNodeApi :: LegacyCtx -> Server Legacy.NodeApi
 legacyNodeApi r =
     hoistServer
         (Proxy :: Proxy Legacy.NodeApi)
         (Handler . ExceptT . try . flip runReaderT r)
         Legacy.nodeServantHandlers
 
+--------------------------------------------------------------------------------
+-- Entry point
+--------------------------------------------------------------------------------
+
+-- | This function launches a node API server, which serves the new V1 API, the
+-- legacy node API, and the documentation server for both.
 launchNodeServer
     :: NodeApiArgs
     -> NtpConfiguration
@@ -149,6 +165,7 @@ launchNodeServer
                 updateConfiguration
                 compileTimeInfo
                 shutdownCtx
+                (ncUpdateContext nodeCtx)
             :<|> legacyApi
 
     concurrently_
@@ -187,6 +204,7 @@ launchNodeServer
     (ipAddress, portNumber) = nodeBackendAddress params
     (docAddress, docPort) = nodeBackendDocAddress params
 
+-- | Assembles the handlers for the new node API.
 handlers
     :: Diffusion IO
     -> TVar NtpStatus
@@ -198,12 +216,17 @@ handlers
     -> UpdateConfiguration
     -> CompileTimeInfo
     -> ShutdownContext
+    -> UpdateContext
     -> ServerT Node.API Handler
-handlers d t s n l ts sv uc ci sc =
+handlers d t s n l ts sv uc ci sc uCtx =
     getNodeSettings ci uc ts sv
     :<|> getNodeInfo d t s n l
-    :<|> applyUpdate sc
-    :<|> postponeUpdate
+    :<|> getNextUpdate uCtx
+    :<|> restartNode sc
+
+--------------------------------------------------------------------------------
+-- Node Settings
+--------------------------------------------------------------------------------
 
 getNodeSettings
     :: CompileTimeInfo
@@ -239,20 +262,31 @@ instance Core.HasSlottingVar SettingsCtx where
     slottingVar =
         lens settingsCtxSlottingVar (\s t -> s { settingsCtxSlottingVar = t })
 
-applyUpdate :: ShutdownContext -> Handler NoContent
-applyUpdate shutdownCtx = liftIO $ do
+--------------------------------------------------------------------------------
+-- Updates
+--------------------------------------------------------------------------------
+
+-- | Handler
+restartNode :: ShutdownContext -> Handler NoContent
+restartNode shutdownCtx = liftIO $ do
     doFail <- testLogFInject (_shdnFInjects shutdownCtx) FInjApplyUpdateNoExit
     unless doFail (runReaderT triggerShutdown shutdownCtx)
     pure NoContent
 
--- | In the old implementation, we would delete the new update from the
--- acid-stae database. We no longer persist this information, so postponing an
--- update is simply a noop.
---
--- TODO: verify this is a real thought and not, in fact, bad
-postponeUpdate :: Handler NoContent
-postponeUpdate = do
-    pure NoContent
+-- | This endpoint does a 404 unless there is an update available. If an update
+-- is available, it returns the 'SoftwareVersion' for that update.
+getNextUpdate :: UpdateContext -> Handler (APIResponse (V1 SoftwareVersion))
+getNextUpdate uc = do
+    mproposalState <- tryReadMVar (ucDownloadedUpdate uc)
+    single <$> case mproposalState of
+        Just proposalState ->
+            pure (V1 (upSoftwareVersion (cpsUpdateProposal proposalState)))
+        Nothing ->
+            throwError err404
+
+--------------------------------------------------------------------------------
+-- Node Info
+--------------------------------------------------------------------------------
 
 getNodeInfo
     :: Diffusion IO
@@ -319,7 +353,6 @@ instance DB.MonadDBRead (ReaderT InfoCtx IO) where
     dbGetSerUndo  = DB.dbGetSerUndoRealDefault
     dbGetSerBlund = DB.dbGetSerBlundRealDefault
 
-
 getNodeSyncProgress
     ::
     ( MonadIO m

node/src/Cardano/Node/Client.hs

@@ -10,23 +10,25 @@ module Cardano.Node.Client
     -- * HTTP instance
     , NodeHttpClient
     , mkHttpClient
+    -- * Deprecated
+    , applyUpdate
+    , postponeUpdate
     ) where
 
 import           Universum
 
 import           Data.Aeson (FromJSON)
 import qualified Data.Aeson as Aeson
 import           Network.HTTP.Client (Manager)
-import           Network.HTTP.Media.MediaType (MediaType)
 import           Servant ((:<|>) (..))
 import           Servant.Client (BaseUrl (..), ClientEnv (..), ClientM,
-                     GenResponse (..), Response, ServantError, client,
-                     runClientM)
+                     GenResponse (..), ServantError, client, runClientM)
 import qualified Servant.Client as Servant
 
 import           Cardano.Node.API (nodeV1Api)
 import           Pos.Chain.Txp (Utxo)
-import           Pos.Node.API (ForceNtpCheck, NodeInfo, NodeSettings)
+import qualified Pos.Chain.Update as Core
+import           Pos.Node.API (ForceNtpCheck, NodeInfo, NodeSettings, V1)
 import           Pos.Util.Jsend (ResponseStatus (..))
 import           Pos.Util.Servant (APIResponse (..))
 import           Pos.Web.Types (CConfirmedProposalState)
@@ -49,21 +51,30 @@ data NodeClient m
         :: ForceNtpCheck
         -> m NodeInfo
 
-    , applyUpdate
+    , restartNode
         :: m ()
 
-    , postponeUpdate
-        :: m ()
+    , getNextUpdate
+        :: m (V1 Core.SoftwareVersion)
     } deriving (Generic)
 
 
+-- | A backwards compatibility wrapper for 'restartNode'.
+applyUpdate :: NodeClient m -> m ()
+applyUpdate = restartNode
+{-# DEPRECATED applyUpdate "Use 'restartNode' instead." #-}
+
+-- | 'postponeUpdate' was removed from the API. This is a backwards
+-- compatibility wrapper that is deprecated.
+postponeUpdate :: Applicative m => NodeClient n -> m ()
+postponeUpdate _ = pure ()
+{-# DEPRECATED postponeUpdate "This endpoint was turned into a noop." #-}
+
 data ClientError a
     = KnownError a
-    | DecodeFailure Text Response
-    | UnsupportedContentType MediaType Response
-    | InvalidContentTypeHeader Response
-    | ConnectionError Text
+    | ErrFromServant Servant.ServantError
     deriving (Show, Generic, Eq)
+
 instance Exception a => Exception (ClientError a)
 
 fromServantError :: FromJSON a => ServantError -> ClientError a
@@ -73,18 +84,11 @@ fromServantError = \case
             Just (APIResponse a ErrorStatus _) ->
                 KnownError a
             Just _ ->
-                DecodeFailure "API failed with non-error response ?!?" r
+                ErrFromServant $ Servant.DecodeFailure "API failed with non-error response ?!?" r
             Nothing ->
-                DecodeFailure "Invalid / Non-JSEnd API Error Response" r
-    Servant.DecodeFailure t r ->
-        DecodeFailure t r
-    Servant.UnsupportedContentType m r ->
-        UnsupportedContentType m r
-    Servant.InvalidContentTypeHeader r ->
-        InvalidContentTypeHeader r
-    Servant.ConnectionError t ->
-        ConnectionError t
-
+                ErrFromServant $ Servant.DecodeFailure "Invalid / Non-JSEnd API Error Response" r
+    err ->
+        ErrFromServant err
 
 -- * HTTP Instance
 
@@ -103,10 +107,10 @@ mkHttpClient baseUrl manager = NodeClient
         fmap wrData $ run getNodeSettingsR
     , getNodeInfo =
         fmap wrData . run . getNodeInfoR
-    , applyUpdate =
-        void $ run applyUpdateR
-    , postponeUpdate =
-        void $ run postponeUpdateR
+    , getNextUpdate =
+        wrData <$> run getNextUpdateR
+    , restartNode =
+        void $ run restartNodeR
     }
   where
     run :: forall a. ClientM a -> ExceptT (ClientError ()) IO a
@@ -118,8 +122,8 @@ mkHttpClient baseUrl manager = NodeClient
 
     (       getNodeSettingsR
      :<|>   getNodeInfoR
-     :<|>   applyUpdateR
-     :<|>   postponeUpdateR
+     :<|>   getNextUpdateR
+     :<|>   restartNodeR
      ):<|>( getUtxoR
      :<|>   getConfirmedProposalsR
      ) = client nodeV1Api