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