split out side-affect-full deployment

lib/command/src/Obelisk/Command/Deploy.hs

@@ -135,6 +135,8 @@ deployPush deployPath getNixBuilders = do
   builders <- getNixBuilders
   let moduleFile = deployPath </> "module.nix"
   moduleFileExists <- liftIO $ doesFileExist moduleFile
+  let knownHostsPath = deployPath </> "backend_known_hosts"
+      sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
   buildOutputByHost <- ifor (Map.fromSet (const ()) hosts) $ \host () -> do
     --TODO: What does it mean if this returns more or less than 1 line of output?
     [result] <- fmap lines $ nixCmd $ NixCmd_Build $ def
@@ -152,14 +154,27 @@ deployPush deployPath getNixBuilders = do
         , boolArg "enableHttps" enableHttps
         ] <> [rawArg "module" ("import " <> toNixPath moduleFile) | moduleFileExists ])
       & nixCmdConfig_builders .~ builders
-    pure result
-  let knownHostsPath = deployPath </> "backend_known_hosts"
-      sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
-  withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host outputPath -> do
+    pure (DeployBuildOutput sshOpts result)
+  deployPushImpl deployPath buildOutputByHost
+  putLog Notice $ "Deployed => " <> T.pack route
+
+
+data DeployBuildOutput = DeployBuildOutput
+  { _deployBuildOutput_sshOpts :: [String]
+  , _deployBuildOutput_outputPath :: String
+  }
+
+deployPushImpl
+  :: MonadObelisk m
+  => FilePath -- ^ Deploy Path
+  -> Map.Map String DeployBuildOutput
+  -> m ()
+deployPushImpl deployPath buildOutputByHost = do
+  withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host (DeployBuildOutput sshOpts outputPath) -> do
     callProcess'
       (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
       "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
-  withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
+  withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host (DeployBuildOutput sshOpts _) -> do
     callProcessAndLogOutput (Notice, Warning) $
       proc rsyncPath
         [ "-e " <> sshPath <> " " <> unwords sshOpts
@@ -168,7 +183,7 @@ deployPush deployPath getNixBuilders = do
         , "root@" <> host <> ":/var/lib/backend"
         ]
   --TODO: Create GC root so we're sure our closure won't go away during this time period
-  withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
+  withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host (DeployBuildOutput sshOpts outputPath) -> do
     callProcessAndLogOutput (Notice, Warning) $
       proc sshPath $ sshOpts <>
         [ "root@" <> host
@@ -186,7 +201,6 @@ deployPush deployPath getNixBuilders = do
         gitProc deployPath ["add", "."]
       callProcessAndLogOutput (Debug, Error) $
         gitProc deployPath ["commit", "-m", "New deployment"]
-  putLog Notice $ "Deployed => " <> T.pack route
   where
     callProcess' envMap cmd args = do
       let p = setEnvOverride (envMap <>) $ setDelegateCtlc True $ proc cmd args