@@ -17,6 +17,7 @@ import Data.Bits
1717import qualified Data.ByteString.Lazy as BSL
1818import Data.Default
1919import qualified Data.Map as Map
20+import Data.Maybe (listToMaybe)
2021import qualified Data.Set as Set
2122import Data.String.Here.Interpolated (i)
2223import qualified Data.Text as T
@@ -48,6 +49,8 @@ data DeployInitOpts = DeployInitOpts
4849 , _deployInitOpts_enableHttps :: Bool
4950 } deriving Show
5051
52+data DoActivateDeployment = DoActivateDeployment deriving (Eq, Ord, Show)
53+
5154deployInit :: MonadObelisk m => DeployInitOpts -> FilePath -> m ()
5255deployInit deployOpts root = do
5356 let deployDir = _deployInitOpts_outputDir deployOpts
@@ -85,12 +88,13 @@ deployInit' thunkPtr (DeployInitOpts deployDir sshKeyPath hostnames route adminE
8588 --accidentally create a production deployment that uses development
8689 --credentials to connect to some resources. This could result in, e.g.,
8790 --production data backed up to a dev environment.
88− withSpinner "Creating project configuration directories" $ liftIO $ do
89− mapM_ (createDirectoryIfMissing True)
90− [ deployDir </> "config" </> "backend"
91− , deployDir </> "config" </> "common"
92− , deployDir </> "config" </> "frontend"
93− ]
91+ withSpinner "Creating project configuration directories" $ do
92+ callProcessAndLogOutput (Notice, Error) $
93+ proc "mkdir" [ "-p"
94+ , deployDir </> "config" </> "backend"
95+ , deployDir </> "config" </> "common"
96+ , deployDir </> "config" </> "frontend"
97+ ]
9498
9599 let srcDir = deployDir </> "src"
96100 withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ do
@@ -116,22 +120,28 @@ setupObeliskImpl deployDir = liftIO $ do
116120 createDirectoryIfMissing True implDir
117121 writeFile (implDir </> "default.nix") $ "(import " <> toNixPath (goBackUp </> "src") <> " {}).obelisk"
118122
119−deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
120−deployPush deployPath getNixBuilders = do
123+deployPush :: MonadObelisk m => FilePath -> Maybe DoActivateDeployment -> m [String] -> m ()
124+deployPush deployPath doActivateDeployment getNixBuilders = do
121125 hosts <- Set.fromList . filter (/= mempty) . lines <$> readDeployConfig deployPath "backend_hosts"
122126 adminEmail <- readDeployConfig deployPath "admin_email"
123127 enableHttps <- read <$> readDeployConfig deployPath "enable_https"
124128 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
125129 routeHost <- getHostFromRoute enableHttps route
126− let srcPath = deployPath </> "src"
127− thunkPtr <- readThunk srcPath >>= \case
128− Right (ThunkData_Packed _ ptr) -> return ptr
129− Right ThunkData_Checkout -> do
130− checkGitCleanStatus srcPath True >>= \case
131− True -> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath
132− False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
133− Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)
134− let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr
130+ let
131+ srcPath = deployPath </> "src"
132+ handleUnpackedWith f = checkGitCleanStatus srcPath True >>= \case
133+ True -> f
134+ False -> failWith $ "ob deploy push: ensure " <> T.pack srcPath <> " has no pending changes and latest is pushed upstream."
135+
136+ version' <- readThunk srcPath >>= \case
137+ Right (ThunkData_Packed _ ptr) -> return $ Just $ show $ _thunkRev_commit $ _thunkPtr_rev ptr
138+ Right ThunkData_Checkout -> handleUnpackedWith $ Just . show . _thunkRev_commit . _thunkPtr_rev <$> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath
139+ Left err -> do
140+ putLog Warning [i|No valid thunk found at ${srcPath} due to ${err}: Attempting to find commit hash anyway.|]
141+ handleUnpackedWith $ fmap show . listToMaybe . T.lines <$> readGitProcess srcPath ["rev-parse", "HEAD"]
142+ version <- case version' of
143+ Nothing -> failWith [i|Could not determine commit hash of ${srcPath}|]
144+ Just v -> v <$ putLog Notice [i|Deploying commit ${v}|]
135145 builders <- getNixBuilders
136146 let moduleFile = deployPath </> "module.nix"
137147 moduleFileExists <- liftIO $ doesFileExist moduleFile
@@ -159,33 +169,35 @@ deployPush deployPath getNixBuilders = do
159169 callProcess'
160170 (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
161171 "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
162− withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
163− callProcessAndLogOutput (Notice, Warning) $
164− proc rsyncPath
165− [ "-e " <> sshPath <> " " <> unwords sshOpts
166− , "-qarvz"
167− , deployPath </> "config"
168− , "root@" <> host <> ":/var/lib/backend"
169− ]
170− --TODO: Create GC root so we're sure our closure won't go away during this time period
171− withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
172− callProcessAndLogOutput (Notice, Warning) $
173− proc sshPath $ sshOpts <>
174− [ "root@" <> host
175− , unwords
176− -- Note that we don't want to $(staticWhich "nix-env") here, because this is executing on a remote machine
177− [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
178− , "&&"
179− , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
172+ case doActivateDeployment of
173+ Nothing -> putLog Warning "Skipping activation of deployment; server is unchanged"
174+ Just _ -> do
175+ withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
176+ callProcessAndLogOutput (Notice, Warning) $
177+ proc "rsync"
178+ [ "-e ssh " <> unwords sshOpts
179+ , "-qarvz"
180+ , deployPath </> "config"
181+ , "root@" <> host <> ":/var/lib/backend"
182+ ]
183+ --TODO: Create GC root so we're sure our closure won't go away during this time period
184+ withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
185+ callProcessAndLogOutput (Notice, Warning) $
186+ proc "ssh" $ sshOpts <>
187+ [ "root@" <> host
188+ , unwords
189+ [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
190+ , "&&"
191+ , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
192+ ]
180193 ]
181− ]
182194 isClean <- checkGitCleanStatus deployPath True
183195 when (not isClean) $ do
184196 withSpinner "Committing changes to Git" $ do
185− callProcessAndLogOutput (Debug, Error) $
186− gitProc deployPath ["add", "."]
187− callProcessAndLogOutput (Debug, Error) $
188− gitProc deployPath ["commit", "-m", "New deployment"]
197+ callProcessAndLogOutput (Debug, Error) $ proc "git"
198+ ["-C", deployPath, "add", "."]
199+ callProcessAndLogOutput (Debug, Error) $ proc "git"
200+ ["-C", deployPath, "commit", "-m", "New deployment"]
189201 putLog Notice $ "Deployed => " <> T.pack route
190202 where
191203 callProcess' envMap cmd args = do
@@ -315,7 +327,7 @@ readDeployConfig deployDir fname = liftIO $ do
315327
316328verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
317329verifyHostKey knownHostsPath keyPath hostName =
318− callProcessAndLogOutput (Notice, Warning) $ proc sshPath $
330+ callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
319331 sshArgs knownHostsPath keyPath True <>
320332 [ "root@" <> hostName
321333 , "-o", "NumberOfPasswordPrompts=0"