@@ -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 (isJust, listToMaybe)
2021import qualified Data.Set as Set
2122import Data.String.Here.Interpolated (i)
2223import qualified Data.Text as T
@@ -85,12 +86,13 @@ deployInit' thunkPtr (DeployInitOpts deployDir sshKeyPath hostnames route adminE
8586 --accidentally create a production deployment that uses development
8687 --credentials to connect to some resources. This could result in, e.g.,
8788 --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− ]
89+ withSpinner "Creating project configuration directories" $ do
90+ callProcessAndLogOutput (Notice, Error) $
91+ proc "mkdir" [ "-p"
92+ , deployDir </> "config" </> "backend"
93+ , deployDir </> "config" </> "common"
94+ , deployDir </> "config" </> "frontend"
95+ ]
9496
9597 let srcDir = deployDir </> "src"
9698 withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ do
@@ -123,15 +125,18 @@ deployPush deployPath getNixBuilders = do
123125 enableHttps <- read <$> readDeployConfig deployPath "enable_https"
124126 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
125127 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
128+ let
129+ srcPath = deployPath </> "src"
130+ handleUnpackedWith f = checkGitCleanStatus srcPath True >>= \case
131+ True -> f
132+ False -> failWith $ "ob deploy push: ensure " <> T.pack srcPath <> " has no pending changes and latest is pushed upstream."
133+
134+ version' <- readThunk srcPath >>= \case
135+ Right (ThunkData_Packed _ ptr) -> return $ Just $ show $ _thunkRev_commit $ _thunkPtr_rev ptr
136+ Right ThunkData_Checkout -> handleUnpackedWith $ Just . show . _thunkRev_commit . _thunkPtr_rev <$> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath
137+ Left err -> do
138+ putLog Warning [i|No valid thunk found at ${srcPath} due to ${err}: Attempting to find commit hash anyway.|]
139+ handleUnpackedWith $ fmap show . listToMaybe . T.lines <$> readGitProcess srcPath ["rev-parse", "HEAD"]
135140 builders <- getNixBuilders
136141 let moduleFile = deployPath </> "module.nix"
137142 moduleFileExists <- liftIO $ doesFileExist moduleFile
@@ -148,7 +153,7 @@ deployPush deployPath getNixBuilders = do
148153 [ strArg "hostName" host
149154 , strArg "adminEmail" adminEmail
150155 , strArg "routeHost" routeHost
151− , strArg "version" version
156+ , strArg "version" $ maybe "Deployment was done with a dirty source tree" id version'
152157 , boolArg "enableHttps" enableHttps
153158 ] <> [rawArg "module" ("import " <> toNixPath moduleFile) | moduleFileExists ])
154159 & nixCmdConfig_builders .~ builders
@@ -161,8 +166,8 @@ deployPush deployPath getNixBuilders = do
161166 "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
162167 withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
163168 callProcessAndLogOutput (Notice, Warning) $
164− proc rsyncPath
165− [ "-e " <> sshPath <> " " <> unwords sshOpts
169+ proc "rsync"
170+ [ "-e ssh " <> unwords sshOpts
166171 , "-qarvz"
167172 , deployPath </> "config"
168173 , "root@" <> host <> ":/var/lib/backend"
@@ -170,22 +175,22 @@ deployPush deployPath getNixBuilders = do
170175 --TODO: Create GC root so we're sure our closure won't go away during this time period
171176 withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
172177 callProcessAndLogOutput (Notice, Warning) $
173− proc sshPath $ sshOpts <>
178+ proc "ssh" $ sshOpts <>
174179 [ "root@" <> host
175180 , unwords
176− -- Note that we don't want to $(staticWhich "nix-env") here, because this is executing on a remote machine
177181 [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
178182 , "&&"
179183 , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
180184 ]
181185 ]
182− isClean <- checkGitCleanStatus deployPath True
183− when (not isClean) $ do
184− 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"]
186+ when (isJust version') $ do
187+ isClean <- checkGitCleanStatus deployPath True
188+ when (not isClean) $ do
189+ withSpinner "Committing changes to Git" $ do
190+ callProcessAndLogOutput (Debug, Error) $ proc "git"
191+ ["-C", deployPath, "add", "."]
192+ callProcessAndLogOutput (Debug, Error) $ proc "git"
193+ ["-C", deployPath, "commit", "-m", "New deployment"]
189194 putLog Notice $ "Deployed => " <> T.pack route
190195 where
191196 callProcess' envMap cmd args = do
@@ -315,7 +320,7 @@ readDeployConfig deployDir fname = liftIO $ do
315320
316321verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
317322verifyHostKey knownHostsPath keyPath hostName =
318− callProcessAndLogOutput (Notice, Warning) $ proc sshPath $
323+ callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
319324 sshArgs knownHostsPath keyPath True <>
320325 [ "root@" <> hostName
321326 , "-o", "NumberOfPasswordPrompts=0"