@@ -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 (listToMaybe)
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
@@ -49,8 +48,6 @@ data DeployInitOpts = DeployInitOpts
49 , _deployInitOpts_enableHttps :: Bool
48 , _deployInitOpts_enableHttps :: Bool
50 } deriving Show
49 } deriving Show
52−data DoActivateDeployment = DoActivateDeployment deriving (Eq, Ord, Show)
54deployInit :: MonadObelisk m => DeployInitOpts -> FilePath -> m ()
51deployInit :: MonadObelisk m => DeployInitOpts -> FilePath -> m ()
55deployInit deployOpts root = do
52deployInit deployOpts root = do
56 let deployDir = _deployInitOpts_outputDir deployOpts
53 let deployDir = _deployInitOpts_outputDir deployOpts
@@ -88,13 +85,12 @@ deployInit' thunkPtr (DeployInitOpts deployDir sshKeyPath hostnames route adminE
88 --accidentally create a production deployment that uses development
85 --accidentally create a production deployment that uses development
89 --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.,
90 --production data backed up to a dev environment.
87 --production data backed up to a dev environment.
91− withSpinner "Creating project configuration directories" $ do
88+ withSpinner "Creating project configuration directories" $ liftIO $ do
92− callProcessAndLogOutput (Notice, Error) $
89+ mapM_ (createDirectoryIfMissing True)
94− , deployDir </> "config" </> "backend"
90+ [ deployDir </> "config" </> "backend"
95− , deployDir </> "config" </> "common"
91+ , deployDir </> "config" </> "common"
96− , deployDir </> "config" </> "frontend"
92+ , deployDir </> "config" </> "frontend"
99 let srcDir = deployDir </> "src"
95 let srcDir = deployDir </> "src"
100 withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ do
96 withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ do
@@ -120,28 +116,22 @@ setupObeliskImpl deployDir = liftIO $ do
120 createDirectoryIfMissing True implDir
116 createDirectoryIfMissing True implDir
121 writeFile (implDir </> "default.nix") $ "(import " <> toNixPath (goBackUp </> "src") <> " {}).obelisk"
117 writeFile (implDir </> "default.nix") $ "(import " <> toNixPath (goBackUp </> "src") <> " {}).obelisk"
123−deployPush :: MonadObelisk m => FilePath -> Maybe DoActivateDeployment -> m [String] -> m ()
119+deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
124−deployPush deployPath doActivateDeployment getNixBuilders = do
120+deployPush deployPath getNixBuilders = do
125 hosts <- Set.fromList . filter (/= mempty) . lines <$> readDeployConfig deployPath "backend_hosts"
121 hosts <- Set.fromList . filter (/= mempty) . lines <$> readDeployConfig deployPath "backend_hosts"
126 adminEmail <- readDeployConfig deployPath "admin_email"
122 adminEmail <- readDeployConfig deployPath "admin_email"
127 enableHttps <- read <$> readDeployConfig deployPath "enable_https"
123 enableHttps <- read <$> readDeployConfig deployPath "enable_https"
128 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
124 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
129 routeHost <- getHostFromRoute enableHttps route
125 routeHost <- getHostFromRoute enableHttps route
131− srcPath = deployPath </> "src"
126+ let srcPath = deployPath </> "src"
127+ thunkPtr <- readThunk srcPath >>= \case
128+ Right (ThunkData_Packed _ ptr) -> return ptr
129+ Right ThunkData_Checkout -> do
132− handleUnpackedWith f = checkGitCleanStatus srcPath True >>= \case
130+ checkGitCleanStatus srcPath True >>= \case
133− True -> f
131+ True -> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath
134− False -> failWith $ "ob deploy push: ensure " <> T.pack 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."
135−
133+ Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)
136− version' <- readThunk srcPath >>= \case
134+ let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr
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
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}|]
145 builders <- getNixBuilders
135 builders <- getNixBuilders
146 let moduleFile = deployPath </> "module.nix"
136 let moduleFile = deployPath </> "module.nix"
147 moduleFileExists <- liftIO $ doesFileExist moduleFile
137 moduleFileExists <- liftIO $ doesFileExist moduleFile
@@ -169,35 +159,33 @@ deployPush deployPath doActivateDeployment getNixBuilders = do
169 callProcess'
159 callProcess'
170 (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
160 (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
171 "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
161 "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
172− case doActivateDeployment of
173− Nothing -> putLog Warning "Skipping activation of deployment; server is unchanged"
175− withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
162+ withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
176− callProcessAndLogOutput (Notice, Warning) $
163+ callProcessAndLogOutput (Notice, Warning) $
177− proc "rsync"
164+ proc rsyncPath
178− [ "-e ssh " <> unwords sshOpts
165+ [ "-e " <> sshPath <> " " <> unwords sshOpts
179− , "-qarvz"
166+ , "-qarvz"
180− , deployPath </> "config"
167+ , deployPath </> "config"
181− , "root@" <> host <> ":/var/lib/backend"
168+ , "root@" <> host <> ":/var/lib/backend"
183− --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
184− withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
171+ withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
185− callProcessAndLogOutput (Notice, Warning) $
172+ callProcessAndLogOutput (Notice, Warning) $
186− proc "ssh" $ sshOpts <>
173+ proc sshPath $ sshOpts <>
187− [ "root@" <> host
174+ [ "root@" <> host
188− , unwords
175+ , unwords
176+ -- Note that we don't want to $(staticWhich "nix-env") here, because this is executing on a remote machine
189− [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
177+ [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
191− , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
179+ , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
194 isClean <- checkGitCleanStatus deployPath True
182 isClean <- checkGitCleanStatus deployPath True
195 when (not isClean) $ do
183 when (not isClean) $ do
196 withSpinner "Committing changes to Git" $ do
184 withSpinner "Committing changes to Git" $ do
197− callProcessAndLogOutput (Debug, Error) $ proc "git"
185+ callProcessAndLogOutput (Debug, Error) $
198− ["-C", deployPath, "add", "."]
186+ gitProc deployPath ["add", "."]
199− callProcessAndLogOutput (Debug, Error) $ proc "git"
187+ callProcessAndLogOutput (Debug, Error) $
200− ["-C", deployPath, "commit", "-m", "New deployment"]
188+ gitProc deployPath ["commit", "-m", "New deployment"]
201 putLog Notice $ "Deployed => " <> T.pack route
189 putLog Notice $ "Deployed => " <> T.pack route
203 callProcess' envMap cmd args = do
191 callProcess' envMap cmd args = do
@@ -327,7 +315,7 @@ readDeployConfig deployDir fname = liftIO $ do
328verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
316verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
329verifyHostKey knownHostsPath keyPath hostName =
317verifyHostKey knownHostsPath keyPath hostName =
330− callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
318+ callProcessAndLogOutput (Notice, Warning) $ proc sshPath $
331 sshArgs knownHostsPath keyPath True <>
319 sshArgs knownHostsPath keyPath True <>
332 [ "root@" <> hostName
320 [ "root@" <> hostName
333 , "-o", "NumberOfPasswordPrompts=0"
321 , "-o", "NumberOfPasswordPrompts=0"