git.iko.soy/obelisk
on 63c7b21 help sign in
obelisk/lib/command/src/Obelisk/Command/Deploy.hs
239 lines 10 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ViewPatterns #-}
6module Obelisk.Command.Deploy where
8import Control.Lens
9import Control.Monad
10import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try)
11import Control.Monad.IO.Class (liftIO)
12import Data.Bits
13import Data.Default
14import qualified Data.Map as Map
15import qualified Data.Set as Set
16import qualified Data.Text as T
17import qualified Data.Text.IO as T
18import System.Directory
19import System.Environment (getEnvironment)
20import System.FilePath
21import System.Posix.Files
22import System.Process (delegate_ctlc, env, proc)
23import Text.URI (URI)
24import qualified Text.URI as URI
25import Text.URI.Lens
27import Obelisk.App (MonadObelisk)
28import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, failWith, putLog, withSpinner)
29import Obelisk.Command.Nix
30import Obelisk.Command.Project
31import Obelisk.Command.Thunk
32import Obelisk.Command.Utils
34deployInit
35 :: MonadObelisk m
36 => ThunkPtr
37 -> FilePath
38 -> FilePath
39 -> FilePath
40 -> [String] -- ^ hostnames
41 -> String -- ^ route
42 -> String -- ^ admin email
43 -> Bool -- ^ enable https
44 -> m ()
45deployInit thunkPtr configDir deployDir sshKeyPath hostnames route adminEmail enableHttps = do
46 (hasConfigDir, localKey) <- withSpinner ("Preparing " <> T.pack deployDir) $ do
47 hasConfigDir <- liftIO $ do
48 createDirectoryIfMissing True deployDir
49 doesDirectoryExist configDir
50 localKey <- liftIO (doesFileExist sshKeyPath) >>= \case
51 False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath
52 True -> pure $ deployDir </> "ssh_key"
53 callProcessAndLogOutput (Notice, Error) $
54 proc "cp" [sshKeyPath, localKey]
55 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode
56 return $ (hasConfigDir, localKey)
57 withSpinner "Validating configuration" $ do
58 void $ getHostFromRoute enableHttps route -- make sure that hostname is present
59 forM_ hostnames $ \hostname -> do
60 putLog Notice $ "Verifying host keys (" <> T.pack hostname <> ")"
61 -- Note: we can't use a spinner here as this function will prompt the user.
62 verifyHostKey (deployDir </> "backend_known_hosts") localKey hostname
63 when hasConfigDir $ withSpinner "Importing project configuration" $ do
64 callProcessAndLogOutput (Notice, Error) $
65 proc "cp" [ "-r" , "-T" , configDir , deployDir </> "config"]
66 withSpinner "Writing deployment configuration" $ do
67 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames
68 writeDeployConfig deployDir "enable_https" $ show enableHttps
69 writeDeployConfig deployDir "admin_email" adminEmail
70 writeDeployConfig deployDir ("config" </> "common" </> "route") $ route
71 withSpinner "Creating source thunk (./src)" $ liftIO $ do
72 createThunk (deployDir </> "src") thunkPtr
73 setupObeliskImpl deployDir
74 withSpinner ("Initializing git repository (" <> T.pack deployDir <> ")") $
75 initGit deployDir
77setupObeliskImpl :: FilePath -> IO ()
78setupObeliskImpl deployDir = do
79 let implDir = toImplDir deployDir
80 createDirectoryIfMissing True implDir
81 writeFile (implDir </> "default.nix") "(import ../../src {}).obelisk"
83deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
84deployPush deployPath getNixBuilders = do
85 hosts <- Set.fromList . filter (/= mempty) . lines <$> readDeployConfig deployPath "backend_hosts"
86 adminEmail <- readDeployConfig deployPath "admin_email"
87 enableHttps <- read <$> readDeployConfig deployPath "enable_https"
88 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
89 routeHost <- getHostFromRoute enableHttps route
90 let srcPath = deployPath </> "src"
91 thunkPtr <- readThunk srcPath >>= \case
92 Right (ThunkData_Packed ptr) -> return ptr
93 Right (ThunkData_Checkout _) -> do
94 checkGitCleanStatus srcPath True >>= \case
95 True -> packThunk srcPath
96 False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
97 Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)
98 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr
99 builders <- getNixBuilders
100 buildOutputByHost <- ifor (Map.fromSet (const ()) hosts) $ \host () -> do
101 --TODO: What does it mean if this returns more or less than 1 line of output?
102 [result] <- fmap lines $ nixCmd $ NixCmd_Build $ def
103 & nixCmdConfig_target .~ Target
104 { _target_path = Just srcPath
105 , _target_attr = Just "server.system"
106 , _target_expr = Nothing
107 }
108 & nixBuildConfig_outLink .~ OutLink_None
109 & nixCmdConfig_args .~
110 [ strArg "hostName" host
111 , strArg "adminEmail" adminEmail
112 , strArg "routeHost" routeHost
113 , strArg "version" version
114 , boolArg "enableHttps" enableHttps
115 , rawArg "config" $ deployPath </> "config"
116 ]
117 & nixCmdConfig_builders .~ builders
118 pure result
119 let knownHostsPath = deployPath </> "backend_known_hosts"
120 sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
121 withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host outputPath -> do
122 callProcess'
123 (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
124 "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
125 --TODO: Create GC root so we're sure our closure won't go away during this time period
126 withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
127 callProcessAndLogOutput (Notice, Warning) $
128 proc "ssh" $ sshOpts <>
129 [ "root@" <> host
130 , unwords
131 [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
132 , "&&"
133 , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
134 ]
135 ]
136 isClean <- checkGitCleanStatus deployPath True
137 when (not isClean) $ do
138 withSpinner "Commiting changes to Git" $ do
139 callProcessAndLogOutput (Debug, Error) $ proc "git"
140 ["-C", deployPath, "add", "."]
141 callProcessAndLogOutput (Debug, Error) $ proc "git"
142 ["-C", deployPath, "commit", "-m", "New deployment"]
143 putLog Notice $ "Deployed => " <> T.pack route
144 where
145 callProcess' envMap cmd args = do
146 processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment
147 let p = (proc cmd args) { delegate_ctlc = True, env = Just processEnv }
148 callProcessAndLogOutput (Notice, Notice) p
150deployUpdate :: MonadObelisk m => FilePath -> m ()
151deployUpdate deployPath = updateThunkToLatest (deployPath </> "src") Nothing
153deployMobile :: MonadObelisk m => String -> [String] -> m ()
154deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do
155 let srcDir = root </> "src"
156 exists <- liftIO $ doesDirectoryExist srcDir
157 unless exists $ failWith "ob test should be run inside of a deploy directory"
158 result <- nixBuildAttrWithCache srcDir $ platform <> ".frontend"
159 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs
161-- | Simplified deployment configuration mechanism. At one point we may revisit this.
162writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
163writeDeployConfig deployDir fname = liftIO . writeFile (deployDir </> fname)
165readDeployConfig :: MonadObelisk m => FilePath -> FilePath -> m String
166readDeployConfig deployDir fname = liftIO $ do
167 fmap (T.unpack . T.strip) $ T.readFile $ deployDir </> fname
169verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
170verifyHostKey knownHostsPath keyPath hostName =
171 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
172 sshArgs knownHostsPath keyPath True <>
173 [ "root@" <> hostName
174 , "-o", "NumberOfPasswordPrompts=0"
175 , "exit"
176 ]
178sshArgs :: FilePath -> FilePath -> Bool -> [String]
179sshArgs knownHostsPath keyPath askHostKeyCheck =
180 [ "-o", "UserKnownHostsFile=" <> knownHostsPath
181 , "-o", "StrictHostKeyChecking=" <> if askHostKeyCheck then "ask" else "yes"
182 , "-i", keyPath
183 ]
185-- common/route validation
186-- TODO: move these to executable-config once the typed-config stuff is done.
188data InvalidRoute
189 = InvalidRoute_NotHttps URI
190 | InvalidRoute_MissingScheme URI
191 | InvalidRoute_MissingHost URI
192 | InvalidRoute_HasPort URI
193 | InvalidRoute_HasPath URI
194 deriving Show
196instance Exception InvalidRoute where
197 displayException = \case
198 InvalidRoute_MissingScheme uri -> route uri "must have an URI scheme"
199 InvalidRoute_NotHttps uri -> route uri "must be HTTPS"
200 InvalidRoute_MissingHost uri -> route uri "must contain a hostname"
201 InvalidRoute_HasPort uri -> route uri "cannot specify port"
202 InvalidRoute_HasPath uri -> route uri "cannot contain path"
203 where
204 route uri err = T.unpack $ "Route (" <> URI.render uri <> ") " <> err
206-- | Get the hostname from a https route
207--
208-- Fail if the route is invalid (i.e, no host present or scheme is not https)
209getHostFromRoute
210 :: MonadObelisk m
211 => Bool -- ^ Ensure https?
212 -> String
213 -> m String
214getHostFromRoute mustBeHttps route = do
215 result :: Either InvalidRoute String <- try $ do
216 validateCommonRouteAndGetHost mustBeHttps =<< URI.mkURI (T.strip $ T.pack route)
217 either (failWith . T.pack . displayException) pure result
219validateCommonRouteAndGetHost
220 :: (MonadThrow m, MonadObelisk m)
221 => Bool -- ^ Ensure https?
222 -> URI
223 -> m String
224validateCommonRouteAndGetHost mustBeHttps uri = do
225 case uri ^? uriScheme of
226 Just (Just (URI.unRText -> s)) -> case (mustBeHttps, s) of
227 (False, _) -> pure ()
228 (True, "https") -> pure ()
229 _ -> throwM $ InvalidRoute_NotHttps uri
230 _ -> throwM $ InvalidRoute_MissingScheme uri
231 case uri ^. uriPath of
232 [] -> pure ()
233 _path -> throwM $ InvalidRoute_HasPath uri
234 case uri ^? uriAuthority . _Right . authPort of
235 Just (Just _port) -> throwM $ InvalidRoute_HasPort uri
236 _ -> pure ()
237 case uri ^? uriAuthority . _Right . authHost of
238 Nothing -> throwM $ InvalidRoute_MissingHost uri
239 Just sslHost -> return $ T.unpack $ URI.unRText sslHost