@@ -3,23 +3,34 @@
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE ScopedTypeVariables #-}
55{-# LANGUAGE ViewPatterns #-}
6+{-# LANGUAGE DeriveGeneric #-}
7+{-# LANGUAGE TypeApplications #-}
68module Obelisk.Command.Deploy where
79
810import Control.Lens
911import Control.Monad
10−import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try)
12+import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try, bracket_)
1113import Control.Monad.IO.Class (liftIO)
14+import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)
1215import Data.Bits
16+import qualified Data.ByteString.Lazy as BSL
1317import Data.Default
18+import qualified Data.HashMap.Strict as HM
1419import qualified Data.Map as Map
15−import Data.Maybe
20+import Data.Text (Text)
21+import qualified Data.Set as Set
1622import qualified Data.Text as T
1723import qualified Data.Text.IO as T
24+import GHC.Generics
25+import Nix.Convert
26+import Nix.Pretty
27+import Nix.Value
1828import System.Directory
1929import System.Environment (getEnvironment)
2030import System.FilePath
31+import System.IO
2132import System.Posix.Files
22−import System.Process (delegate_ctlc, env, proc)
33+import System.Process (delegate_ctlc, env, proc, cwd)
2334import Text.URI (URI)
2435import qualified Text.URI as URI
2536import Text.URI.Lens
@@ -82,71 +93,65 @@ setupObeliskImpl deployDir = do
8293
8394deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
8495deployPush deployPath getNixBuilders = do
85− host <- readDeployConfig deployPath "backend_hosts"
96+ hosts <- Set.fromList . filter (/= mempty) . lines <$> readDeployConfig deployPath "backend_hosts"
8697 adminEmail <- readDeployConfig deployPath "admin_email"
8798 enableHttps <- read <$> readDeployConfig deployPath "enable_https"
8899 route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
89100 routeHost <- getHostFromRoute enableHttps route
90101 let srcPath = deployPath </> "src"
91− build = do
92− builders <- getNixBuilders
93− buildOutput <- nixBuild $ def
94− { _nixBuildConfig_target = Target
95− { _target_path = srcPath
96− , _target_attr = Just "server.system"
97− }
98− , _nixBuildConfig_outLink = OutLink_None
99− , _nixBuildConfig_args =
100− [ strArg "hostName" host
101− , strArg "adminEmail" adminEmail
102− , strArg "routeHost" routeHost
103− , boolArg "enableHttps" enableHttps
104− , rawArg "config" $ deployPath </> "config"
105− ]
106− , _nixBuildConfig_builders = builders
107− }
108− return $ listToMaybe $ lines buildOutput
109− result <- readThunk srcPath >>= \case
110− Right (ThunkData_Packed _) ->
111− build
102+ thunkPtr <- readThunk srcPath >>= \case
103+ Right (ThunkData_Packed ptr) -> return ptr
112104 Right (ThunkData_Checkout _) -> do
113105 checkGitCleanStatus srcPath True >>= \case
114− True -> do
115− result <- build
116− packThunk srcPath
117− return result
118− False -> do
119− _ <- failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."
120− return Nothing
121− _ -> return Nothing
122− forM_ result $ \res -> do
123− let knownHostsPath = deployPath </> "backend_known_hosts"
124− sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
125− deployAndSwitch outputPath = do
126− withSpinner "Uploading closure" $ do
127− callProcess'
128− (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
129− "nix-copy-closure" ["-v", "--to", "root@" <> host, "--gzip", outputPath]
130−
131− withSpinner "Switching to new configuration" $ do
132− callProcessAndLogOutput (Notice, Warning) $
133− proc "ssh" $ sshOpts <>
134− [ "root@" <> host
135− , unwords
136− [ "nix-env -p /nix/var/nix/profiles/system --set " <> outputPath
137− , "&&"
138− , "/nix/var/nix/profiles/system/bin/switch-to-configuration switch"
139− ]
140− ]
141− deployAndSwitch res
142− isClean <- checkGitCleanStatus deployPath True
143− when (not isClean) $ do
144− withSpinner "Commiting changes to Git" $ do
145− callProcessAndLogOutput (Debug, Error) $ proc "git"
146− ["-C", deployPath, "add", "."]
147− callProcessAndLogOutput (Debug, Error) $ proc "git"
148− ["-C", deployPath, "commit", "-m", "New deployment"]
149− putLog Notice $ "Deployed => " <> T.pack route
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
150155 where
151156 callProcess' envMap cmd args = do
152157 processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment
@@ -156,13 +161,106 @@ deployPush deployPath getNixBuilders = do
156161deployUpdate :: MonadObelisk m => FilePath -> m ()
157162deployUpdate deployPath = updateThunkToLatest $ deployPath </> "src"
158163
159−deployMobile :: MonadObelisk m => String -> [String] -> m ()
164+keytoolToAndroidConfig :: KeytoolConfig -> HM.HashMap Text (NValueNF Identity)
165+keytoolToAndroidConfig 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+ ]
176+
177+data PlatformDeployment = Android | IOS
178+ deriving (Show, Eq)
179+
180+renderPlatformDeployment :: PlatformDeployment -> String
181+renderPlatformDeployment = \case
182+ Android -> "android"
183+ IOS -> "ios"
184+
185+deployMobile :: MonadObelisk m => PlatformDeployment -> [String] -> m ()
160186deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do
161187 let srcDir = root </> "src"
162188 exists <- liftIO $ doesDirectoryExist srcDir
163189 unless exists $ failWith "ob test should be run inside of a deploy directory"
164− result <- nixBuildAttrWithCache srcDir $ platform <> ".frontend"
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)
165234 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
239+
240+data KeytoolConfig = KeytoolConfig
241+ { _keytoolConfig_keystore :: FilePath
242+ , _keytoolConfig_alias :: String
243+ , _keytoolConfig_storepass :: String
244+ , _keytoolConfig_keypass :: String
245+ } deriving (Show, Generic)
246+
247+instance FromJSON KeytoolConfig
248+instance ToJSON KeytoolConfig
249+
250+createKeystore :: MonadObelisk m => FilePath -> KeytoolConfig -> m ()
251+createKeystore 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+ ]
166264
167265-- | Simplified deployment configuration mechanism. At one point we may revisit this.
168266writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
@@ -177,6 +275,7 @@ verifyHostKey knownHostsPath keyPath hostName =
177275 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
178276 sshArgs knownHostsPath keyPath True <>
179277 [ "root@" <> hostName
278+ , "-o", "NumberOfPasswordPrompts=0"
180279 , "exit"
181280 ]
182281