git.iko.soy/obelisk
on 2cea7df help sign in
obelisk/lib/command/src/Obelisk/Command/Deploy.hs
343 lines 15 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 -> FilePath
51 -> [String] -- ^ hostnames
52 -> String -- ^ route
53 -> String -- ^ admin email
54 -> Bool -- ^ enable https
55 -> m ()
56deployInit thunkPtr configDir deployDir sshKeyPath hostnames route adminEmail enableHttps = do
57 (hasConfigDir, localKey) <- withSpinner ("Preparing " <> T.pack deployDir) $ do
58 hasConfigDir <- liftIO $ do
59 createDirectoryIfMissing True deployDir
60 doesDirectoryExist configDir
61 localKey <- liftIO (doesFileExist sshKeyPath) >>= \case
62 False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath
63 True -> pure $ deployDir </> "ssh_key"
64 callProcessAndLogOutput (Notice, Error) $
65 proc "cp" [sshKeyPath, localKey]
66 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode
67 return $ (hasConfigDir, localKey)
68 withSpinner "Validating configuration" $ do
69 void $ getHostFromRoute enableHttps route -- make sure that hostname is present
70 forM_ hostnames $ \hostname -> do
71 putLog Notice $ "Verifying host keys (" <> T.pack hostname <> ")"
72 -- Note: we can't use a spinner here as this function will prompt the user.
73 verifyHostKey (deployDir </> "backend_known_hosts") localKey hostname
74 when hasConfigDir $ withSpinner "Importing project configuration" $ do
75 callProcessAndLogOutput (Notice, Error) $
76 proc "cp" [ "-r" , "-T" , configDir , deployDir </> "config"]
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 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 , rawArg "config" $ deployPath </> "config"
127 ]
128 & nixCmdConfig_builders .~ builders
129 pure result
130 let knownHostsPath = deployPath </> "backend_known_hosts"
131 sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
132 withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host outputPath -> do
133 callProcess'
134 (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
135 "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
136 --TODO: Create GC root so we're sure our closure won't go away during this time period
137 withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
138 callProcessAndLogOutput (Notice, Warning) $
139 proc "ssh" $ sshOpts <>
140 [ "root@" <> host
141 , unwords
142 [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
143 , "&&"
144 , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
145 ]
146 ]
147 isClean <- checkGitCleanStatus deployPath True
148 when (not isClean) $ do
149 withSpinner "Commiting changes to Git" $ do
150 callProcessAndLogOutput (Debug, Error) $ proc "git"
151 ["-C", deployPath, "add", "."]
152 callProcessAndLogOutput (Debug, Error) $ proc "git"
153 ["-C", deployPath, "commit", "-m", "New deployment"]
154 putLog Notice $ "Deployed => " <> T.pack route
155 where
156 callProcess' envMap cmd args = do
157 processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment
158 let p = (proc cmd args) { delegate_ctlc = True, env = Just processEnv }
159 callProcessAndLogOutput (Notice, Notice) p
161deployUpdate :: MonadObelisk m => FilePath -> m ()
162deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"
164keytoolToAndroidConfig :: KeytoolConfig -> HM.HashMap Text (NValueNF Identity)
165keytoolToAndroidConfig conf = runIdentity $ do
166 path <- toValue $ Path $ _keytoolConfig_keystore conf
167 storepass <- toValue $ T.pack $ _keytoolConfig_storepass conf
168 alias <- toValue $ T.pack $ _keytoolConfig_alias conf
169 keypass <- toValue $ T.pack $ _keytoolConfig_keypass conf
170 return $ HM.fromList
171 [ ("storeFile", path)
172 , ("storePassword", storepass)
173 , ("keyAlias", alias)
174 , ("keyPassword", keypass)
175 ]
177data PlatformDeployment = Android | IOS
178 deriving (Show, Eq)
180renderPlatformDeployment :: PlatformDeployment -> String
181renderPlatformDeployment = \case
182 Android -> "android"
183 IOS -> "ios"
185deployMobile :: MonadObelisk m => PlatformDeployment -> [String] -> m ()
186deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do
187 let srcDir = root </> "src"
188 exists <- liftIO $ doesDirectoryExist srcDir
189 unless exists $ failWith "ob test should be run inside of a deploy directory"
190 nixBuildTarget <- case platform of
191 Android -> do
192 let keystorePath = root </> "android_keystore.jks"
193 keytoolConfPath = root </> "android_keytool_config.json"
194 hasKeystore <- liftIO $ doesFileExist keystorePath
195 when (not hasKeystore) $ do
196 -- TODO log instructions for how to modify the keystore
197 putLog Notice $ "Creating keystore: " <> T.pack keystorePath
198 putLog Notice "Enter a keystore password: "
199 keyStorePassword <- liftIO $ withEcho False getLine
200 putLog Notice "Re-enter the keystore password: "
201 keyStorePassword' <- liftIO $ withEcho False getLine
202 unless (keyStorePassword' == keyStorePassword) $ failWith "passwords do not match"
203 let keyToolConf = KeytoolConfig
204 { _keytoolConfig_keystore = keystorePath
205 , _keytoolConfig_alias = "obelisk"
206 , _keytoolConfig_storepass = keyStorePassword
207 , _keytoolConfig_keypass = keyStorePassword
208 }
209 createKeystore root $ keyToolConf
210 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf
211 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath
212 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"
213 keytoolConfContents <- liftIO $ BSL.readFile keytoolConfPath
214 liftIO $ putStrLn $ show keytoolConfContents
215 releaseKey <- case eitherDecode keytoolConfContents of
216 Left err -> failWith $ T.pack err
217 Right conf -> do
218 let nvset = toValue @(HM.HashMap Text (NValueNF Identity)) @Identity @(NValueNF Identity) $ keytoolToAndroidConfig conf
219 return $ printNix $ runIdentity nvset
220 return $ Target
221 { _target_path = Nothing
222 , _target_attr = Nothing
223 , _target_expr = Just $ "with (import " <> srcDir <> " {}); " <> renderPlatformDeployment platform <> ".frontend.override (drv: { releaseKey = (if builtins.isNull drv.releaseKey then {} else drv.releaseKey) // " <> releaseKey <> "; })"
224 }
225 IOS -> return $ Target
226 { _target_path = Nothing
227 , _target_attr = Just "ios.frontend"
228 , _target_expr = Nothing
229 }
230 result <- nixCmd $ NixCmd_Build $ def
231 & nixBuildConfig_outLink .~ OutLink_None
232 & nixCmdConfig_target .~ nixBuildTarget
233 putLog Notice $ T.pack $ "Your recently built android apk can be found at the following path: " <> (show result)
234 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs
235 where
236 withEcho showEcho f = do
237 prevEcho <- hGetEcho stdin
238 bracket_ (hSetEcho stdin showEcho) (hSetEcho stdin prevEcho) f
240data KeytoolConfig = KeytoolConfig
241 { _keytoolConfig_keystore :: FilePath
242 , _keytoolConfig_alias :: String
243 , _keytoolConfig_storepass :: String
244 , _keytoolConfig_keypass :: String
245 } deriving (Show, Generic)
247instance FromJSON KeytoolConfig
248instance ToJSON KeytoolConfig
250createKeystore :: MonadObelisk m => FilePath -> KeytoolConfig -> m ()
251createKeystore root config = do
252 let expr = "with (import " <> toImplDir root <> ").reflex-platform.nixpkgs; pkgs.mkShell { buildInputs = [ pkgs.jdk ]; }"
253 callProcessAndLogOutput (Notice,Notice) $ (proc "nix-shell" ["-E" , expr, "--run" , keytoolCmd]) { cwd = Just root }
254 where
255 keytoolCmd = processToShellString "keytool"
256 [ "-genkeypair", "-noprompt"
257 , "-keystore", _keytoolConfig_keystore config
258 , "-keyalg", "RSA", "-keysize", "2048"
259 , "-validity", "1000000000"
260 , "-storepass", _keytoolConfig_storepass config
261 , "-alias", _keytoolConfig_alias config
262 , "-keypass", _keytoolConfig_keypass config
263 ]
265-- | Simplified deployment configuration mechanism. At one point we may revisit this.
266writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
267writeDeployConfig deployDir fname = liftIO . writeFile (deployDir </> fname)
269readDeployConfig :: MonadObelisk m => FilePath -> FilePath -> m String
270readDeployConfig deployDir fname = liftIO $ do
271 fmap (T.unpack . T.strip) $ T.readFile $ deployDir </> fname
273verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
274verifyHostKey knownHostsPath keyPath hostName =
275 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
276 sshArgs knownHostsPath keyPath True <>
277 [ "root@" <> hostName
278 , "-o", "NumberOfPasswordPrompts=0"
279 , "exit"
280 ]
282sshArgs :: FilePath -> FilePath -> Bool -> [String]
283sshArgs knownHostsPath keyPath askHostKeyCheck =
284 [ "-o", "UserKnownHostsFile=" <> knownHostsPath
285 , "-o", "StrictHostKeyChecking=" <> if askHostKeyCheck then "ask" else "yes"
286 , "-i", keyPath
287 ]
289-- common/route validation
290-- TODO: move these to executable-config once the typed-config stuff is done.
292data InvalidRoute
293 = InvalidRoute_NotHttps URI
294 | InvalidRoute_MissingScheme URI
295 | InvalidRoute_MissingHost URI
296 | InvalidRoute_HasPort URI
297 | InvalidRoute_HasPath URI
298 deriving Show
300instance Exception InvalidRoute where
301 displayException = \case
302 InvalidRoute_MissingScheme uri -> route uri "must have an URI scheme"
303 InvalidRoute_NotHttps uri -> route uri "must be HTTPS"
304 InvalidRoute_MissingHost uri -> route uri "must contain a hostname"
305 InvalidRoute_HasPort uri -> route uri "cannot specify port"
306 InvalidRoute_HasPath uri -> route uri "cannot contain path"
307 where
308 route uri err = T.unpack $ "Route (" <> URI.render uri <> ") " <> err
310-- | Get the hostname from a https route
311--
312-- Fail if the route is invalid (i.e, no host present or scheme is not https)
313getHostFromRoute
314 :: MonadObelisk m
315 => Bool -- ^ Ensure https?
316 -> String
317 -> m String
318getHostFromRoute mustBeHttps route = do
319 result :: Either InvalidRoute String <- try $ do
320 validateCommonRouteAndGetHost mustBeHttps =<< URI.mkURI (T.strip $ T.pack route)
321 either (failWith . T.pack . displayException) pure result
323validateCommonRouteAndGetHost
324 :: (MonadThrow m, MonadObelisk m)
325 => Bool -- ^ Ensure https?
326 -> URI
327 -> m String
328validateCommonRouteAndGetHost mustBeHttps uri = do
329 case uri ^? uriScheme of
330 Just (Just (URI.unRText -> s)) -> case (mustBeHttps, s) of
331 (False, _) -> pure ()
332 (True, "https") -> pure ()
333 _ -> throwM $ InvalidRoute_NotHttps uri
334 _ -> throwM $ InvalidRoute_MissingScheme uri
335 case uri ^. uriPath of
336 [] -> pure ()
337 _path -> throwM $ InvalidRoute_HasPath uri
338 case uri ^? uriAuthority . _Right . authPort of
339 Just (Just _port) -> throwM $ InvalidRoute_HasPort uri
340 _ -> pure ()
341 case uri ^? uriAuthority . _Right . authHost of
342 Nothing -> throwM $ InvalidRoute_MissingHost uri
343 Just sslHost -> return $ T.unpack $ URI.unRText sslHost