git.iko.soy/obelisk
on ae@static-which-prefetch help sign in
obelisk/lib/command/src/Obelisk/Command/Deploy.hs
386 lines 17 kB history raw
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE QuasiQuotes #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ViewPatterns #-}
8module Obelisk.Command.Deploy where
10import Control.Applicative (liftA2)
11import Control.Lens
12import Control.Monad
13import Control.Monad.Catch (Exception (displayException), MonadThrow, bracket, throwM, try)
14import Control.Monad.IO.Class (MonadIO, liftIO)
15import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)
16import Data.Bits
17import qualified Data.ByteString.Lazy as BSL
18import Data.Default
19import qualified Data.Map as Map
20import qualified Data.Set as Set
21import Data.String.Here.Interpolated (i)
22import qualified Data.Text as T
23import qualified Data.Text.IO as T
24import GHC.Generics
25import System.Directory
26import System.FilePath
27import System.IO
28import System.PosixCompat.Files
29import Text.URI (URI)
30import qualified Text.URI as URI
31import Text.URI.Lens
33import Obelisk.App (MonadObelisk)
34import Obelisk.CliApp (
35 Severity (..), callProcessAndLogOutput, failWith, proc, putLog,
36 setCwd, setDelegateCtlc, setEnvOverride, withSpinner)
37import Obelisk.Command.Nix
38import Obelisk.Command.Project
39import Obelisk.Command.Thunk
40import Obelisk.Command.Utils
42data DeployInitOpts = DeployInitOpts
43 { _deployInitOpts_outputDir :: FilePath
44 , _deployInitOpts_sshKey :: FilePath
45 , _deployInitOpts_hostname :: [String]
46 , _deployInitOpts_route :: String
47 , _deployInitOpts_adminEmail :: String
48 , _deployInitOpts_enableHttps :: Bool
49 } deriving Show
51deployInit :: MonadObelisk m => DeployInitOpts -> FilePath -> m ()
52deployInit deployOpts root = do
53 let deployDir = _deployInitOpts_outputDir deployOpts
54 rootEqualsTarget <- liftIO $ liftA2 equalFilePath (canonicalizePath root) (canonicalizePath deployDir)
55 when rootEqualsTarget $
56 failWith [i|Deploy directory ${deployDir} should not be the same as project root.|]
57 thunkPtr <- readThunk root >>= \case
58 Right (ThunkData_Packed _ ptr) -> return ptr
59 _ -> getThunkPtr CheckClean_NotIgnored root Nothing
60 deployInit' thunkPtr deployOpts
62deployInit'
63 :: MonadObelisk m
64 => ThunkPtr
65 -> DeployInitOpts
66 -> m ()
67deployInit' thunkPtr (DeployInitOpts deployDir sshKeyPath hostnames route adminEmail enableHttps) = do
68 liftIO $ createDirectoryIfMissing True deployDir
69 localKey <- withSpinner ("Preparing " <> T.pack deployDir) $ do
70 localKey <- liftIO (doesFileExist sshKeyPath) >>= \case
71 False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath
72 True -> pure $ deployDir </> "ssh_key"
73 callProcessAndLogOutput (Notice, Error) $
74 proc cp [sshKeyPath, localKey]
75 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode
76 return localKey
77 withSpinner "Validating configuration" $ do
78 void $ getHostFromRoute enableHttps route -- make sure that hostname is present
79 forM_ hostnames $ \hostname -> do
80 putLog Notice $ "Verifying host keys (" <> T.pack hostname <> ")"
81 -- Note: we can't use a spinner here as this function will prompt the user.
82 verifyHostKey (deployDir </> "backend_known_hosts") localKey hostname
83 --IMPORTANT: We cannot copy config directory from the development project to
84 --the deployment directory. If we do, it's very likely someone will
85 --accidentally create a production deployment that uses development
86 --credentials to connect to some resources. This could result in, e.g.,
87 --production data backed up to a dev environment.
88 withSpinner "Creating project configuration directories" $ do
89 callProcessAndLogOutput (Notice, Error) $
90 proc "mkdir" [ "-p"
91 , deployDir </> "config" </> "backend"
92 , deployDir </> "config" </> "common"
93 , deployDir </> "config" </> "frontend"
94 ]
96 let srcDir = deployDir </> "src"
97 withSpinner ("Creating source thunk (" <> T.pack (makeRelative deployDir srcDir) <> ")") $ do
98 createThunk srcDir $ Right thunkPtr
99 setupObeliskImpl deployDir
101 withSpinner "Writing deployment configuration" $ do
102 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames
103 writeDeployConfig deployDir "enable_https" $ show enableHttps
104 writeDeployConfig deployDir "admin_email" adminEmail
105 writeDeployConfig deployDir ("config" </> "common" </> "route") route
106 writeDeployConfig deployDir "module.nix" $
107 "(import " <> toNixPath (makeRelative deployDir srcDir) <> " {}).obelisk.serverModules.mkBaseEc2"
109 withSpinner ("Initializing git repository (" <> T.pack deployDir <> ")") $
110 initGit deployDir
112setupObeliskImpl :: MonadIO m => FilePath -> m ()
113setupObeliskImpl deployDir = liftIO $ do
114 let
115 implDir = toImplDir deployDir
116 goBackUp = foldr (</>) "" $ (".." <$) $ splitPath $ makeRelative deployDir implDir
117 createDirectoryIfMissing True implDir
118 writeFile (implDir </> "default.nix") $ "(import " <> toNixPath (goBackUp </> "src") <> " {}).obelisk"
120deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
121deployPush deployPath getNixBuilders = do
122 hosts <- Set.fromList . filter (/= mempty) . lines <$> readDeployConfig deployPath "backend_hosts"
123 adminEmail <- readDeployConfig deployPath "admin_email"
124 enableHttps <- read <$> readDeployConfig deployPath "enable_https"
125 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
126 routeHost <- getHostFromRoute enableHttps route
127 let srcPath = deployPath </> "src"
128 thunkPtr <- readThunk srcPath >>= \case
129 Right (ThunkData_Packed _ ptr) -> return ptr
130 Right ThunkData_Checkout -> do
131 checkGitCleanStatus srcPath True >>= \case
132 True -> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath
133 False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
134 Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)
135 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr
136 builders <- getNixBuilders
137 let moduleFile = deployPath </> "module.nix"
138 moduleFileExists <- liftIO $ doesFileExist moduleFile
139 buildOutputByHost <- ifor (Map.fromSet (const ()) hosts) $ \host () -> do
140 --TODO: What does it mean if this returns more or less than 1 line of output?
141 [result] <- fmap lines $ nixCmd $ NixCmd_Build $ def
142 & nixCmdConfig_target .~ Target
143 { _target_path = Just srcPath
144 , _target_attr = Just "server.system"
145 , _target_expr = Nothing
146 }
147 & nixBuildConfig_outLink .~ OutLink_None
148 & nixCmdConfig_args .~ (
149 [ strArg "hostName" host
150 , strArg "adminEmail" adminEmail
151 , strArg "routeHost" routeHost
152 , strArg "version" version
153 , boolArg "enableHttps" enableHttps
154 ] <> [rawArg "module" ("import " <> toNixPath moduleFile) | moduleFileExists ])
155 & nixCmdConfig_builders .~ builders
156 pure result
157 let knownHostsPath = deployPath </> "backend_known_hosts"
158 sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
159 withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host outputPath -> do
160 callProcess'
161 (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
162 "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
163 withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
164 callProcessAndLogOutput (Notice, Warning) $
165 proc "rsync"
166 [ "-e ssh " <> unwords sshOpts
167 , "-qarvz"
168 , deployPath </> "config"
169 , "root@" <> host <> ":/var/lib/backend"
170 ]
171 --TODO: Create GC root so we're sure our closure won't go away during this time period
172 withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
173 callProcessAndLogOutput (Notice, Warning) $
174 proc "ssh" $ sshOpts <>
175 [ "root@" <> host
176 , unwords
177 [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
178 , "&&"
179 , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
180 ]
181 ]
182 isClean <- checkGitCleanStatus deployPath True
183 when (not isClean) $ do
184 withSpinner "Committing changes to Git" $ do
185 callProcessAndLogOutput (Debug, Error) $ proc "git"
186 ["-C", deployPath, "add", "."]
187 callProcessAndLogOutput (Debug, Error) $ proc "git"
188 ["-C", deployPath, "commit", "-m", "New deployment"]
189 putLog Notice $ "Deployed => " <> T.pack route
190 where
191 callProcess' envMap cmd args = do
192 let p = setEnvOverride (envMap <>) $ setDelegateCtlc True $ proc cmd args
193 callProcessAndLogOutput (Notice, Notice) p
195deployUpdate :: MonadObelisk m => FilePath -> m ()
196deployUpdate deployPath = updateThunkToLatest (ThunkUpdateConfig Nothing (ThunkConfig Nothing)) (deployPath </> "src")
198data PlatformDeployment = Android | IOS
199 deriving (Show, Eq)
201renderPlatformDeployment :: PlatformDeployment -> String
202renderPlatformDeployment = \case
203 Android -> "android"
204 IOS -> "ios"
206deployMobile :: forall m. MonadObelisk m => PlatformDeployment -> [String] -> m ()
207deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do
208 let srcDir = root </> "src"
209 configDir = root </> "config"
210 exists <- liftIO $ doesDirectoryExist srcDir
211 unless exists $ failWith "ob test should be run inside of a deploy directory"
212 (nixBuildTarget, extraArgs) <- case platform of
213 Android -> do
214 let keystorePath = root </> "android_keystore.jks"
215 keytoolConfPath = root </> "android_keytool_config.json"
216 hasKeystore <- liftIO $ doesFileExist keystorePath
217 when (not hasKeystore) $ do
218 -- TODO log instructions for how to modify the keystore
219 putLog Notice $ "Creating keystore: " <> T.pack keystorePath
220 putLog Notice "Enter a keystore password: "
221 keyStorePassword <- liftIO $ withEcho False getLine
222 putLog Notice "Re-enter the keystore password: "
223 keyStorePassword' <- liftIO $ withEcho False getLine
224 unless (keyStorePassword' == keyStorePassword) $ failWith "passwords do not match"
225 let keyToolConf = KeytoolConfig
226 { _keytoolConfig_keystore = keystorePath
227 , _keytoolConfig_alias = "obelisk"
228 , _keytoolConfig_storepass = keyStorePassword
229 , _keytoolConfig_keypass = keyStorePassword
230 }
231 createKeystore root keyToolConf
232 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf
233 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath
234 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"
235 keytoolConfContents <- liftIO $ BSL.readFile keytoolConfPath
236 keyArgs <- case eitherDecode keytoolConfContents :: Either String KeytoolConfig of
237 Left err -> failWith $ T.pack err
238 Right conf -> pure
239 [ "--sign"
240 , "--store-file", _keytoolConfig_keystore conf
241 , "--store-password", _keytoolConfig_storepass conf
242 , "--key-alias", _keytoolConfig_alias conf
243 , "--key-password", _keytoolConfig_keypass conf
244 ]
245 let expr = mconcat
246 [ "with (import ", toNixPath srcDir, " {});"
247 , "android.frontend.override (drv: {"
248 , "isRelease = true;"
249 , "staticSrc = (passthru.__androidWithConfig ", configDir, ").frontend.staticSrc;"
250 , "assets = (passthru.__androidWithConfig ", configDir, ").frontend.assets;"
251 , "})"
252 ]
253 return (Target
254 { _target_path = Nothing
255 , _target_attr = Nothing
256 , _target_expr = Just expr
257 }, keyArgs)
258 IOS -> do
259 let expr = mconcat
260 [ "with (import ", toNixPath srcDir, " {});"
261 , "ios.frontend.override (_: { staticSrc = (passthru.__iosWithConfig ", toNixPath configDir, ").frontend.staticSrc; })"
262 ]
263 return (Target
264 { _target_path = Nothing
265 , _target_attr = Nothing
266 , _target_expr = Just expr
267 }, [])
268 result <- nixCmd $ NixCmd_Build $ def
269 & nixBuildConfig_outLink .~ OutLink_None
270 & nixCmdConfig_target .~ nixBuildTarget
271 let mobileArtifact = case platform of
272 IOS -> "iOS App"
273 Android -> "Android APK"
274 putLog Notice $ T.pack $ unwords ["Your recently built", mobileArtifact, "can be found at the following path:", show result]
275 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") (mobileArgs ++ extraArgs)
276 where
277 withEcho showEcho f = bracket
278 (do
279 prevEcho <- hGetEcho stdin
280 hSetEcho stdin showEcho
281 pure prevEcho
282 )
283 (hSetEcho stdin)
284 (const f)
286data KeytoolConfig = KeytoolConfig
287 { _keytoolConfig_keystore :: FilePath
288 , _keytoolConfig_alias :: String
289 , _keytoolConfig_storepass :: String
290 , _keytoolConfig_keypass :: String
291 } deriving (Show, Generic)
293instance FromJSON KeytoolConfig
294instance ToJSON KeytoolConfig
296createKeystore :: MonadObelisk m => FilePath -> KeytoolConfig -> m ()
297createKeystore root config =
298 callProcessAndLogOutput (Notice, Notice) $ setCwd (Just root) $ proc jreKeyToolPath
299 [ "-genkeypair", "-noprompt"
300 , "-keystore", _keytoolConfig_keystore config
301 , "-keyalg", "RSA", "-keysize", "2048"
302 , "-validity", "1000000"
303 , "-storepass", _keytoolConfig_storepass config
304 , "-alias", _keytoolConfig_alias config
305 , "-keypass", _keytoolConfig_keypass config
306 ]
308-- | Simplified deployment configuration mechanism. At one point we may revisit this.
309writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
310writeDeployConfig deployDir fname = liftIO . writeFile (deployDir </> fname)
312readDeployConfig :: MonadObelisk m => FilePath -> FilePath -> m String
313readDeployConfig deployDir fname = liftIO $ do
314 fmap (T.unpack . T.strip) $ T.readFile $ deployDir </> fname
316verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
317verifyHostKey knownHostsPath keyPath hostName =
318 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
319 sshArgs knownHostsPath keyPath True <>
320 [ "root@" <> hostName
321 , "-o", "NumberOfPasswordPrompts=0"
322 , "exit"
323 ]
325sshArgs :: FilePath -> FilePath -> Bool -> [String]
326sshArgs knownHostsPath keyPath askHostKeyCheck =
327 [ "-o", "UserKnownHostsFile=" <> knownHostsPath
328 , "-o", "StrictHostKeyChecking=" <> if askHostKeyCheck then "ask" else "yes"
329 , "-i", keyPath
330 ]
332-- common/route validation
333-- TODO: move these to executable-config once the typed-config stuff is done.
335data InvalidRoute
336 = InvalidRoute_NotHttps URI
337 | InvalidRoute_MissingScheme URI
338 | InvalidRoute_MissingHost URI
339 | InvalidRoute_HasPort URI
340 | InvalidRoute_HasPath URI
341 deriving Show
343instance Exception InvalidRoute where
344 displayException = \case
345 InvalidRoute_MissingScheme uri -> route uri "must have an URI scheme"
346 InvalidRoute_NotHttps uri -> route uri "must be HTTPS"
347 InvalidRoute_MissingHost uri -> route uri "must contain a hostname"
348 InvalidRoute_HasPort uri -> route uri "cannot specify port"
349 InvalidRoute_HasPath uri -> route uri "cannot contain path"
350 where
351 route uri err = T.unpack $ "Route (" <> URI.render uri <> ") " <> err
353-- | Get the hostname from a https route
354--
355-- Fail if the route is invalid (i.e, no host present or scheme is not https)
356getHostFromRoute
357 :: MonadObelisk m
358 => Bool -- ^ Ensure https?
359 -> String
360 -> m String
361getHostFromRoute mustBeHttps route = do
362 result :: Either InvalidRoute String <- try $ do
363 validateCommonRouteAndGetHost mustBeHttps =<< URI.mkURI (T.strip $ T.pack route)
364 either (failWith . T.pack . displayException) pure result
366validateCommonRouteAndGetHost
367 :: (MonadThrow m, MonadObelisk m)
368 => Bool -- ^ Ensure https?
369 -> URI
370 -> m String
371validateCommonRouteAndGetHost mustBeHttps uri = do
372 case uri ^? uriScheme of
373 Just (Just (URI.unRText -> s)) -> case (mustBeHttps, s) of
374 (False, _) -> pure ()
375 (True, "https") -> pure ()
376 _ -> throwM $ InvalidRoute_NotHttps uri
377 _ -> throwM $ InvalidRoute_MissingScheme uri
378 case uri ^. uriPath of
379 [] -> pure ()
380 _path -> throwM $ InvalidRoute_HasPath uri
381 case uri ^? uriAuthority . _Right . authPort of
382 Just (Just _port) -> throwM $ InvalidRoute_HasPort uri
383 _ -> pure ()
384 case uri ^? uriAuthority . _Right . authHost of
385 Nothing -> throwM $ InvalidRoute_MissingHost uri
386 Just sslHost -> return $ T.unpack $ URI.unRText sslHost