@@ -3,22 +3,30 @@
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE ScopedTypeVariables #-}
55{-# LANGUAGE ViewPatterns #-}
6+{-# LANGUAGE DeriveGeneric #-}
67module Obelisk.Command.Deploy where
78
89import Control.Lens
910import Control.Monad
10−import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try)
11+import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try, bracket_)
1112import Control.Monad.IO.Class (liftIO)
13+import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)
1214import Data.Bits
15+import qualified Data.ByteString.Lazy as BSL
1316import Data.Default
1417import Data.List (isSuffixOf)
18+import Data.Map (Map)
1519import qualified Data.Map as Map
1620import Data.Maybe
21+import Data.Text (Text)
22+import qualified Data.Set as Set
1723import qualified Data.Text as T
1824import qualified Data.Text.IO as T
25+import GHC.Generics
1926import System.Directory
2027import System.Environment (getEnvironment)
2128import System.FilePath
29+import System.IO
2230import System.Posix.Files
2331import System.Process (delegate_ctlc, env, proc, readCreateProcess, cwd)
2432import Text.URI (URI)
@@ -83,71 +91,65 @@ setupObeliskImpl deployDir = do
8391
8492deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
8593deployPush deployPath getNixBuilders = do
86− host <- readDeployConfig deployPath "backend_hosts"
94+ hosts <- Set.fromList . filter (/= mempty) . lines <$> readDeployConfig deployPath "backend_hosts"
8795 adminEmail <- readDeployConfig deployPath "admin_email"
8896 enableHttps <- read <$> readDeployConfig deployPath "enable_https"
8997 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
9098 routeHost <- getHostFromRoute enableHttps route
9199 let srcPath = deployPath </> "src"
92− build = do
93− builders <- getNixBuilders
94− buildOutput <- nixBuild $ def
95− { _nixBuildConfig_target = Target
96− { _target_path = srcPath
97− , _target_attr = Just "server.system"
98− }
99− , _nixBuildConfig_outLink = OutLink_None
100− , _nixBuildConfig_args =
101− [ strArg "hostName" host
102− , strArg "adminEmail" adminEmail
103− , strArg "routeHost" routeHost
104− , boolArg "enableHttps" enableHttps
105− , rawArg "config" $ deployPath </> "config"
106− ]
107− , _nixBuildConfig_builders = builders
108− }
109− return $ listToMaybe $ lines buildOutput
110− result <- readThunk srcPath >>= \case
111− Right (ThunkData_Packed _) ->
112− build
100+ thunkPtr <- readThunk srcPath >>= \case
101+ Right (ThunkData_Packed ptr) -> return ptr
113102 Right (ThunkData_Checkout _) -> do
114103 checkGitCleanStatus srcPath True >>= \case
115− True -> do
116− result <- build
117− packThunk srcPath
118− return result
119− False -> do
120− _ <- failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
121− return Nothing
122− _ -> return Nothing
123− forM_ result $ \res -> do
124− let knownHostsPath = deployPath </> "backend_known_hosts"
125− sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
126− deployAndSwitch outputPath = do
127− withSpinner "Uploading closure" $ do
128− callProcess'
129− (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
130− "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
131−
132− withSpinner "Switching to new configuration" $ do
133− callProcessAndLogOutput (Notice, Warning) $
134− proc "ssh" $ sshOpts <>
135− [ "root@" <> host
136− , unwords
137− [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
138− , "&&"
139− , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
140− ]
141− ]
142− deployAndSwitch res
143− isClean <- checkGitCleanStatus deployPath True
144− when (not isClean) $ do
145− withSpinner "Commiting changes to Git" $ do
146− callProcessAndLogOutput (Debug, Error) $ proc "git"
147− ["-C", deployPath, "add", "."]
148− callProcessAndLogOutput (Debug, Error) $ proc "git"
149− ["-C", deployPath, "commit", "-m", "New deployment"]
150− putLog Notice $ "Deployed => " <> T.pack route
104+ True -> packThunk srcPath
105+ False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
106+ Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)
107+ let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr
108+ builders <- getNixBuilders
109+ buildOutputByHost <- ifor (Map.fromSet (const ()) hosts) $ \host () -> do
110+ --TODO: What does it mean if this returns more or less than 1 line of output?
111+ [result] <- fmap lines $ nixCmd $ NixCmd_Build $ def
112+ & nixCmdConfig_target .~ Target
113+ { _target_path = Just srcPath
114+ , _target_attr = Just "server.system"
115+ , _target_expr = Nothing
116+ }
117+ & nixBuildConfig_outLink .~ OutLink_None
118+ & nixCmdConfig_args .~
119+ [ strArg "hostName" host
120+ , strArg "adminEmail" adminEmail
121+ , strArg "routeHost" routeHost
122+ , strArg "version" version
123+ , boolArg "enableHttps" enableHttps
124+ , rawArg "config" $ deployPath </> "config"
125+ ]
126+ & nixCmdConfig_builders .~ builders
127+ pure result
128+ let knownHostsPath = deployPath </> "backend_known_hosts"
129+ sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
130+ withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host outputPath -> do
131+ callProcess'
132+ (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
133+ "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
134+ --TODO: Create GC root so we're sure our closure won't go away during this time period
135+ withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
136+ callProcessAndLogOutput (Notice, Warning) $
137+ proc "ssh" $ sshOpts <>
138+ [ "root@" <> host
139+ , unwords
140+ [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
141+ , "&&"
142+ , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
143+ ]
144+ ]
145+ isClean <- checkGitCleanStatus deployPath True
146+ when (not isClean) $ do
147+ withSpinner "Commiting changes to Git" $ do
148+ callProcessAndLogOutput (Debug, Error) $ proc "git"
149+ ["-C", deployPath, "add", "."]
150+ callProcessAndLogOutput (Debug, Error) $ proc "git"
151+ ["-C", deployPath, "commit", "-m", "New deployment"]
152+ putLog Notice $ "Deployed => " <> T.pack route
151153 where
152154 callProcess' envMap cmd args = do
153155 processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment
@@ -157,36 +159,88 @@ deployPush deployPath getNixBuilders = do
157159deployUpdate :: MonadObelisk m => FilePath -> m ()
158160deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"
159161
162+keytoolToAndroidConfig :: KeytoolConfig -> Map Text NValue
163+keytoolToAndroidConfig conf = Map.fromList
164+ [ ("storeFile", NValue_Path $ _keytoolConfig_keystore conf)
165+ , ("storePassword", NValue_Text $ T.pack $ _keytoolConfig_storepass conf)
166+ , ("keyAlias", NValue_Text $ T.pack $ _keytoolConfig_alias conf)
167+ , ("keyPassword", NValue_Text $ T.pack $ _keytoolConfig_keypass conf)
168+ ]
169+
170+
160171deployMobile :: MonadObelisk m => String -> [String] -> m ()
161172deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do
162173 let srcDir = root </> "src"
163174 exists <- liftIO $ doesDirectoryExist srcDir
164175 unless exists $ failWith "ob test should be run inside of a deploy directory"
165176 when (platform == "android") $ do
166− let signKeyDir = root </> "backend"
167− -- check to see if config/android/...jks exist
168− androidDirExist <- liftIO $ doesDirectoryExist srcDir
169− -- if it doesn't, create the directory and...
170− -- keyFilename <- liftIO getLine
171− liftIO $ print $ ("Enter desired APK key alias:" :: String)
172− alias <- liftIO getLine
173− liftIO $ print $ ("starting keytool..." :: String)
174− -- ... run keytool command if there isn't a file (what should the name of the file be?) located at config/android
175− searchResults <- liftIO $ findFileWith (\fp -> return $ isSuffixOf ".jks" fp) [signKeyDir] "signKey"
176− -- TODO: How do I allow user to use prompts within keytool?
177− case searchResults of
178− Nothing -> do
179− let impl = toImplDir "."
180− callProcessAndLogOutput (Notice,Notice) (proc "nix-shell"
181− [ "-E"
182− , "with (import " <> impl <> ").reflex-platform.nixpkgs; pkgs.mkShell { buildInputs = [ pkgs.jdk ]; }"
183− , "--run"
184− , "keytool -genkey -v -keystore " <> (signKeyDir </> "obeliskkeystore.jks") <> " -keyalg RSA -keysize 2048 -validity 10000 -alias " <> alias
185− ]) { cwd = Just root }
186− _ -> return ()
187− result <- nixBuildAttrWithCache srcDir $ platform <> ".frontend"
188− putLog Notice $ "Your recently built android apk can be found at the following path: " <> (show result)
189− callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs
177+ let keystorePath = root </> "android_keystore.jks"
178+ keytoolConfPath = root </> "android_keytool_config.json"
179+ hasKeystore <- liftIO $ doesFileExist keystorePath
180+ when (not hasKeystore) $ do
181+ -- TODO log instructions for how to modify the keystore
182+ putLog Notice $ "Creating keystore: " <> T.pack keystorePath
183+ putLog Notice "Enter a keystore password: "
184+ keyStorePassword <- liftIO $ withEcho False getLine
185+ putLog Notice "Re-enter the keystore password: "
186+ keyStorePassword' <- liftIO $ withEcho False getLine
187+ unless (keyStorePassword' == keyStorePassword) $ failWith "passwords do not match"
188+ let keyToolConf = KeytoolConfig
189+ { _keytoolConfig_keystore = keystorePath
190+ , _keytoolConfig_alias = "obelisk"
191+ , _keytoolConfig_storepass = keyStorePassword
192+ , _keytoolConfig_keypass = keyStorePassword
193+ , _keytoolConfig_dname = "CN=example.com, OU=engineering, O=obelisk, L=LinuxLand, S=NY, C=US" -- TODO Read these from config?
194+ }
195+ createKeystore root $ keyToolConf
196+ liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf
197+ checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath
198+ unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"
199+ keytoolConfContents <- liftIO $ BSL.readFile keytoolConfPath
200+ liftIO $ putStrLn $ show keytoolConfContents
201+ releaseKey <- case eitherDecode keytoolConfContents of
202+ Left err -> failWith $ T.pack err
203+ Right conf -> return $ renderAttrset $ keytoolToAndroidConfig conf
204+ result <- nixCmd $ NixCmd_Build $ def
205+ & nixBuildConfig_outLink .~ OutLink_None
206+ & nixCmdConfig_target .~ Target
207+ { _target_path = Nothing
208+ , _target_attr = Nothing
209+ , _target_expr = Just $ "with (import " <> srcDir <> " {}); " <> platform <> ".frontend.override (drv: { releaseKey = (if builtins.isNull drv.releaseKey then {} else drv.releaseKey) // " <> T.unpack releaseKey <> "; })"
210+ }
211+ putLog Notice $ T.pack $ "Your recently built android apk can be found at the following path: " <> (show result)
212+ callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs
213+ where
214+ withEcho showEcho f = do
215+ prevEcho <- hGetEcho stdin
216+ bracket_ (hSetEcho stdin showEcho) (hSetEcho stdin prevEcho) f
217+
218+data KeytoolConfig = KeytoolConfig
219+ { _keytoolConfig_keystore :: FilePath
220+ , _keytoolConfig_alias :: String
221+ , _keytoolConfig_storepass :: String
222+ , _keytoolConfig_keypass :: String
223+ , _keytoolConfig_dname :: String
224+ } deriving (Show, Generic)
225+
226+instance FromJSON KeytoolConfig
227+instance ToJSON KeytoolConfig
228+
229+createKeystore :: MonadObelisk m => FilePath -> KeytoolConfig -> m ()
230+createKeystore root config = do
231+ let expr = "with (import " <> toImplDir root <> ").reflex-platform.nixpkgs; pkgs.mkShell { buildInputs = [ pkgs.jdk ]; }"
232+ callProcessAndLogOutput (Notice,Notice) $ (proc "nix-shell" ["-E" , expr, "--run" , keytoolCmd]) { cwd = Just root }
233+ where
234+ keytoolCmd = unwords $ "keytool" :
235+ [ "-genkeypair -noprompt"
236+ , "-keystore", _keytoolConfig_keystore config
237+ , "-keyalg RSA -keysize 2048 -validity 10000"
238+ , "-storepass", _keytoolConfig_storepass config
239+ , "-alias", _keytoolConfig_alias config
240+ , "-keypass", _keytoolConfig_keypass config
241+ , "-dname ", quote $ _keytoolConfig_dname config
242+ ]
243+ quote x = "\"" <> x <> "\""
190244
191245-- | Simplified deployment configuration mechanism. At one point we may revisit this.
192246writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
@@ -201,6 +255,7 @@ verifyHostKey knownHostsPath keyPath hostName =
201255 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
202256 sshArgs knownHostsPath keyPath True <>
203257 [ "root@" <> hostName
258+ , "-o", "NumberOfPasswordPrompts=0"
204259 , "exit"
205260 ]
206261