git.iko.soy/obelisk
on ee81335 help sign in
obelisk/lib/command/src/Obelisk/Command/Deploy.hs
244 lines 10.0 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 Data.Maybe
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 host <- 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 build = do
92 builders <- getNixBuilders
93 buildOutput <- nixBuild $ def
94 { _nixBuildConfig_target = Target
95 { _target_path = srcPath
96 , _target_attr = Just "server.system"
97 }
98 , _nixBuildConfig_outLink = OutLink_None
99 , _nixBuildConfig_args =
100 [ strArg "hostName" host
101 , strArg "adminEmail" adminEmail
102 , strArg "routeHost" routeHost
103 , boolArg "enableHttps" enableHttps
104 , rawArg "config" $ deployPath </> "config"
105 ]
106 , _nixBuildConfig_builders = builders
107 }
108 return $ listToMaybe $ lines buildOutput
109 result <- readThunk srcPath >>= \case
110 Right (ThunkData_Packed _) ->
111 build
112 Right (ThunkData_Checkout _) -> do
113 checkGitCleanStatus srcPath True >>= \case
114 True -> do
115 result <- build
116 packThunk srcPath
117 return result
118 False -> do
119 _ <- failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
120 return Nothing
121 _ -> return Nothing
122 forM_ result $ \res -> do
123 let knownHostsPath = deployPath </> "backend_known_hosts"
124 sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
125 deployAndSwitch outputPath = do
126 withSpinner "Uploading closure" $ do
127 callProcess'
128 (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
129 "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
131 withSpinner "Switching to new configuration" $ do
132 callProcessAndLogOutput (Notice, Warning) $
133 proc "ssh" $ sshOpts <>
134 [ "root@" <> host
135 , unwords
136 [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
137 , "&&"
138 , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
139 ]
140 ]
141 deployAndSwitch res
142 isClean <- checkGitCleanStatus deployPath True
143 when (not isClean) $ do
144 withSpinner "Commiting changes to Git" $ do
145 callProcessAndLogOutput (Debug, Error) $ proc "git"
146 ["-C", deployPath, "add", "."]
147 callProcessAndLogOutput (Debug, Error) $ proc "git"
148 ["-C", deployPath, "commit", "-m", "New deployment"]
149 putLog Notice $ "Deployed => " <> T.pack route
150 where
151 callProcess' envMap cmd args = do
152 processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment
153 let p = (proc cmd args) { delegate_ctlc = True, env = Just processEnv }
154 callProcessAndLogOutput (Notice, Notice) p
156deployUpdate :: MonadObelisk m => FilePath -> m ()
157deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"
159deployMobile :: MonadObelisk m => String -> [String] -> m ()
160deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do
161 let srcDir = root </> "src"
162 exists <- liftIO $ doesDirectoryExist srcDir
163 unless exists $ failWith "ob test should be run inside of a deploy directory"
164 result <- nixBuildAttrWithCache srcDir $ platform <> ".frontend"
165 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs
167-- | Simplified deployment configuration mechanism. At one point we may revisit this.
168writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
169writeDeployConfig deployDir fname = liftIO . writeFile (deployDir </> fname)
171readDeployConfig :: MonadObelisk m => FilePath -> FilePath -> m String
172readDeployConfig deployDir fname = liftIO $ do
173 fmap (T.unpack . T.strip) $ T.readFile $ deployDir </> fname
175verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
176verifyHostKey knownHostsPath keyPath hostName =
177 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
178 sshArgs knownHostsPath keyPath True <>
179 [ "root@" <> hostName
180 , "exit"
181 ]
183sshArgs :: FilePath -> FilePath -> Bool -> [String]
184sshArgs knownHostsPath keyPath askHostKeyCheck =
185 [ "-o", "UserKnownHostsFile=" <> knownHostsPath
186 , "-o", "StrictHostKeyChecking=" <> if askHostKeyCheck then "ask" else "yes"
187 , "-i", keyPath
188 ]
190-- common/route validation
191-- TODO: move these to executable-config once the typed-config stuff is done.
193data InvalidRoute
194 = InvalidRoute_NotHttps URI
195 | InvalidRoute_MissingScheme URI
196 | InvalidRoute_MissingHost URI
197 | InvalidRoute_HasPort URI
198 | InvalidRoute_HasPath URI
199 deriving Show
201instance Exception InvalidRoute where
202 displayException = \case
203 InvalidRoute_MissingScheme uri -> route uri "must have an URI scheme"
204 InvalidRoute_NotHttps uri -> route uri "must be HTTPS"
205 InvalidRoute_MissingHost uri -> route uri "must contain a hostname"
206 InvalidRoute_HasPort uri -> route uri "cannot specify port"
207 InvalidRoute_HasPath uri -> route uri "cannot contain path"
208 where
209 route uri err = T.unpack $ "Route (" <> URI.render uri <> ") " <> err
211-- | Get the hostname from a https route
212--
213-- Fail if the route is invalid (i.e, no host present or scheme is not https)
214getHostFromRoute
215 :: MonadObelisk m
216 => Bool -- ^ Ensure https?
217 -> String
218 -> m String
219getHostFromRoute mustBeHttps route = do
220 result :: Either InvalidRoute String <- try $ do
221 validateCommonRouteAndGetHost mustBeHttps =<< URI.mkURI (T.strip $ T.pack route)
222 either (failWith . T.pack . displayException) pure result
224validateCommonRouteAndGetHost
225 :: (MonadThrow m, MonadObelisk m)
226 => Bool -- ^ Ensure https?
227 -> URI
228 -> m String
229validateCommonRouteAndGetHost mustBeHttps uri = do
230 case uri ^? uriScheme of
231 Just (Just (URI.unRText -> s)) -> case (mustBeHttps, s) of
232 (False, _) -> pure ()
233 (True, "https") -> pure ()
234 _ -> throwM $ InvalidRoute_NotHttps uri
235 _ -> throwM $ InvalidRoute_MissingScheme uri
236 case uri ^. uriPath of
237 [] -> pure ()
238 _path -> throwM $ InvalidRoute_HasPath uri
239 case uri ^? uriAuthority . _Right . authPort of
240 Just (Just _port) -> throwM $ InvalidRoute_HasPort uri
241 _ -> pure ()
242 case uri ^? uriAuthority . _Right . authHost of
243 Nothing -> throwM $ InvalidRoute_MissingHost uri
244 Just sslHost -> return $ T.unpack $ URI.unRText sslHost