Add backup to the fold

src/Chainweb/RestAPI.hs

@@ -370,14 +370,14 @@ serviceApiApplication v dbs pacts mr (HeaderStream hs) (Rosetta r) backupEnv pbl
             -- TODO: simplify number of resources passing to rosetta
             [ maybe mempty (bool mempty (someRosettaServer v payloads concreteMs cutPeerDb concretePacts) r) cuts
             , PactAPI.somePactServers v pacts
-            , maybe mempty (someBackupServer v) backupEnv
             ]) req resp)
         $ fold
         [ newHealthCheckServer
         , maybe mempty (nodeInfoApi v) cuts
         , maybe mempty Mining.miningApi mr
         , choice "chainweb" $ choice "0.0" $ choice (chainwebVersionToText v) $ fold
             [ maybe mempty headerStreamServer (bool Nothing cuts hs)
+            , choice "backup" $ maybe mempty (newBackupApi v) backupEnv
             , choice "cut" $ maybe mempty newCutGetServer cuts
             , choice "chain" $
                 captureValidChainId v $ fold

src/Chainweb/RestAPI/Backup.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -12,76 +13,91 @@
 
 module Chainweb.RestAPI.Backup
     ( BackupApi
-    , someBackupApi
-    , someBackupServer
+    , newBackupApi
     ) where
 
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Catch
 import Control.Monad.IO.Class
+import qualified Data.ByteString.Lazy as LBS
+import Data.Foldable
 import Data.Proxy
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Network.HTTP.Types
+import Network.Wai
 import System.IO.Unsafe
 import System.LogLevel
 
 import Servant
+import Web.DeepRoute
+import Web.DeepRoute.Wai
 
 import qualified Chainweb.Backup as Backup
 import Chainweb.Logger
 import Chainweb.Time
 
 import Chainweb.RestAPI.Utils
 import Chainweb.Version
+import Chainweb.Utils
 
 type BackupApi_
   =    "make-backup" :> QueryFlag "backupPact" :> PostAccepted '[PlainText] Text
   :<|> "check-backup" :> Capture "backup-name" FilePath :> Get '[PlainText] Backup.BackupStatus
 
 type BackupApi (v :: ChainwebVersionT) = 'ChainwebEndpoint v :> Reassoc BackupApi_
 
-backupApi :: forall (v :: ChainwebVersionT). Proxy (BackupApi v)
-backupApi = Proxy
-
 globalCurrentBackup :: TVar (Maybe Text)
 globalCurrentBackup = unsafePerformIO $! newTVarIO Nothing
 {-# NOINLINE globalCurrentBackup #-}
 
-someBackupApi :: ChainwebVersion -> SomeApi
-someBackupApi (FromSingChainwebVersion (SChainwebVersion :: Sing v)) = SomeApi $ backupApi @v
-
-someBackupServer :: Logger logger => ChainwebVersion -> Backup.BackupEnv logger -> SomeServer
-someBackupServer (FromSingChainwebVersion (SChainwebVersion :: Sing vT)) backupEnv =
-    SomeServer (Proxy @(BackupApi vT)) $ makeBackup :<|> checkBackup
-  where
-    noSuchBackup = err404 { errBody = "no such backup" }
-    makeBackup backupPactFlag = liftIO $ do
-        nextBackupIdentifier <- getNextBackupIdentifier
-        join $ atomically $ do
-            current <- readTVar globalCurrentBackup
-            case current of
-                Nothing -> do
-                    writeTVar globalCurrentBackup (Just nextBackupIdentifier)
-                    return $ doBackup backupPactFlag nextBackupIdentifier
-                Just b -> do
-                    let logg = logFunctionText (Backup._backupLogger backupEnv) Info $
-                            "requested backup, but backup " <> b <> " is already in progress."
-                    return $ b <$ logg
-    doBackup backupPactFlag nextBackupIdentifier = do
+makeBackupHandler :: (MonadIO m, Logger logger) => Backup.BackupEnv logger -> Bool -> m Text
+makeBackupHandler backupEnv backupPactFlag = liftIO $ do
+    nextBackupIdentifier <- getNextBackupIdentifier
+    join $ atomically $ do
+        current <- readTVar globalCurrentBackup
+        case current of
+            Nothing -> do
+                writeTVar globalCurrentBackup (Just nextBackupIdentifier)
+                return $ doBackup nextBackupIdentifier
+            Just b -> do
+                let logg = logFunctionText (Backup._backupLogger backupEnv) Info $
+                        "requested backup, but backup " <> b <> " is already in progress."
+                return $ b <$ logg
+    where
+    doBackup nextBackupIdentifier = do
         _ <- async $ do
             Backup.makeBackup backupEnv options `finally`
                 atomically (writeTVar globalCurrentBackup Nothing)
         return nextBackupIdentifier
-      where
+        where
         options = Backup.BackupOptions
             { Backup._backupIdentifier = T.unpack nextBackupIdentifier
             , Backup._backupPact = backupPactFlag
             }
-    checkBackup backupIdentifier = liftIO $ do
-        status <- Backup.checkBackup backupEnv backupIdentifier
-        maybe (throwM noSuchBackup) pure status
+
+checkBackupHandler :: (MonadIO m, Logger logger) => Backup.BackupEnv logger -> FilePath -> m Backup.BackupStatus
+checkBackupHandler backupEnv backupIdentifier = liftIO $ do
+    status <- Backup.checkBackup backupEnv backupIdentifier
+    maybe noSuchBackup pure status
+
+noSuchBackup :: IO a
+noSuchBackup = errorWithStatus notFound404 "no such backup"
+
+newBackupApi :: Logger logger => ChainwebVersion -> Backup.BackupEnv logger -> Route Application
+newBackupApi v backupEnv = fold
+    [ choice "make-backup" $ terminus methodPost "text/plain" $ \req resp -> do
+        backupPact <- getParams req (queryParamOptional "backup-pact") >>= \case
+            Nothing -> return False
+            Just QueryParamNoValue -> return True
+            Just (QueryParamValue (v :: Text)) -> errorWithStatus badRequest400 "backupPact must not be set to a value, it should be empty if provided"
+        resp . responseLBS accepted202 [] . LBS.fromStrict . T.encodeUtf8 =<< makeBackupHandler backupEnv backupPact
+    , choice "check-backup" $ capture $ terminus methodGet "text/plain" $ \backupIdent req resp -> do
+        resp . responseLBS ok200 [] . LBS.fromStrict . T.encodeUtf8 . toText =<< checkBackupHandler backupEnv backupIdent
+    ]
 
 getNextBackupIdentifier :: IO Text
 getNextBackupIdentifier = do