@@ -17,7 +17,6 @@ import Data.Bits
17import qualified Data.ByteString.Lazy as BSL
17import qualified Data.ByteString.Lazy as BSL
18import Data.Default
18import Data.Default
19import qualified Data.Map as Map
19import qualified Data.Map as Map
20−import Data.Maybe (isJust)
21import qualified Data.Set as Set
20import qualified Data.Set as Set
22import Data.String.Here.Interpolated (i)
21import Data.String.Here.Interpolated (i)
23import qualified Data.Text as T
22import qualified Data.Text as T
@@ -86,13 +85,12 @@ deployInit' thunkPtr (DeployInitOpts deployDir sshKeyPath hostnames route adminE
86 --accidentally create a production deployment that uses development
85 --accidentally create a production deployment that uses development
87 --credentials to connect to some resources. This could result in, e.g.,
86 --credentials to connect to some resources. This could result in, e.g.,
88 --production data backed up to a dev environment.
87 --production data backed up to a dev environment.
89− withSpinner "Creating project configuration directories" $ do
88+ withSpinner "Creating project configuration directories" $ liftIO $ do
90− callProcessAndLogOutput (Notice, Error) $
89+ mapM_ (createDirectoryIfMissing True)
92− , deployDir </> "config" </> "backend"
90+ [ deployDir </> "config" </> "backend"
93− , deployDir </> "config" </> "common"
91+ , deployDir </> "config" </> "common"
94− , deployDir </> "config" </> "frontend"
92+ , deployDir </> "config" </> "frontend"
97 let srcDir = deployDir </> "src"
95 let srcDir = deployDir </> "src"
98 withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ do
96 withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ do
@@ -126,15 +124,14 @@ deployPush deployPath getNixBuilders = do
126 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
124 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
127 routeHost <- getHostFromRoute enableHttps route
125 routeHost <- getHostFromRoute enableHttps route
128 let srcPath = deployPath </> "src"
126 let srcPath = deployPath </> "src"
129− thunkPtr' <- readThunk srcPath >>= \case
127+ thunkPtr <- readThunk srcPath >>= \case
130− Right (ThunkData_Packed _ ptr) -> return $ Just ptr
128+ Right (ThunkData_Packed _ ptr) -> return ptr
131 Right ThunkData_Checkout -> do
129 Right ThunkData_Checkout -> do
132 checkGitCleanStatus srcPath True >>= \case
130 checkGitCleanStatus srcPath True >>= \case
133− True -> Just <$> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath
131+ True -> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath
134− False -> Nothing <$ putLog Warning "Skipping packing of src thunk; won't be able to automatically commit this deployment"
135− -- failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
132+ False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
136 Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)
133 Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)
137− let version' = show . _thunkRev_commit . _thunkPtr_rev <$> thunkPtr'
134+ let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr
138 builders <- getNixBuilders
135 builders <- getNixBuilders
139 let moduleFile = deployPath </> "module.nix"
136 let moduleFile = deployPath </> "module.nix"
140 moduleFileExists <- liftIO $ doesFileExist moduleFile
137 moduleFileExists <- liftIO $ doesFileExist moduleFile
@@ -151,7 +148,7 @@ deployPush deployPath getNixBuilders = do
151 [ strArg "hostName" host
148 [ strArg "hostName" host
152 , strArg "adminEmail" adminEmail
149 , strArg "adminEmail" adminEmail
153 , strArg "routeHost" routeHost
150 , strArg "routeHost" routeHost
154− , strArg "version" $ maybe "Deployment was done with a dirty source tree" id version'
151+ , strArg "version" version
155 , boolArg "enableHttps" enableHttps
152 , boolArg "enableHttps" enableHttps
156 ] <> [rawArg "module" ("import " <> toNixPath moduleFile) | moduleFileExists ])
153 ] <> [rawArg "module" ("import " <> toNixPath moduleFile) | moduleFileExists ])
157 & nixCmdConfig_builders .~ builders
154 & nixCmdConfig_builders .~ builders
@@ -164,8 +161,8 @@ deployPush deployPath getNixBuilders = do
164 "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
161 "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
165 withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
162 withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
166 callProcessAndLogOutput (Notice, Warning) $
163 callProcessAndLogOutput (Notice, Warning) $
167− proc "rsync"
164+ proc rsyncPath
168− [ "-e ssh " <> unwords sshOpts
165+ [ "-e " <> sshPath <> " " <> unwords sshOpts
169 , "-qarvz"
166 , "-qarvz"
170 , deployPath </> "config"
167 , deployPath </> "config"
171 , "root@" <> host <> ":/var/lib/backend"
168 , "root@" <> host <> ":/var/lib/backend"
@@ -173,22 +170,22 @@ deployPush deployPath getNixBuilders = do
173 --TODO: Create GC root so we're sure our closure won't go away during this time period
170 --TODO: Create GC root so we're sure our closure won't go away during this time period
174 withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
171 withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
175 callProcessAndLogOutput (Notice, Warning) $
172 callProcessAndLogOutput (Notice, Warning) $
176− proc "ssh" $ sshOpts <>
173+ proc sshPath $ sshOpts <>
177 [ "root@" <> host
174 [ "root@" <> host
178 , unwords
175 , unwords
176+ -- Note that we don't want to $(staticWhich "nix-env") here, because this is executing on a remote machine
179 [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
177 [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
181 , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
179 , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
184− when (isJust version') $ do
185− isClean <- checkGitCleanStatus deployPath True
182+ isClean <- checkGitCleanStatus deployPath True
186− when (not isClean) $ do
183+ when (not isClean) $ do
187− withSpinner "Committing changes to Git" $ do
184+ withSpinner "Committing changes to Git" $ do
188− callProcessAndLogOutput (Debug, Error) $ proc "git"
185+ callProcessAndLogOutput (Debug, Error) $
189− ["-C", deployPath, "add", "."]
186+ gitProc deployPath ["add", "."]
190− callProcessAndLogOutput (Debug, Error) $ proc "git"
187+ callProcessAndLogOutput (Debug, Error) $
191− ["-C", deployPath, "commit", "-m", "New deployment"]
188+ gitProc deployPath ["commit", "-m", "New deployment"]
192 putLog Notice $ "Deployed => " <> T.pack route
189 putLog Notice $ "Deployed => " <> T.pack route
194 callProcess' envMap cmd args = do
191 callProcess' envMap cmd args = do
@@ -318,7 +315,7 @@ readDeployConfig deployDir fname = liftIO $ do
319verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
316verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
320verifyHostKey knownHostsPath keyPath hostName =
317verifyHostKey knownHostsPath keyPath hostName =
321− callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
318+ callProcessAndLogOutput (Notice, Warning) $ proc sshPath $
322 sshArgs knownHostsPath keyPath True <>
319 sshArgs knownHostsPath keyPath True <>
323 [ "root@" <> hostName
320 [ "root@" <> hostName
324 , "-o", "NumberOfPasswordPrompts=0"
321 , "-o", "NumberOfPasswordPrompts=0"