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