@@ -2,9 +2,12 @@
22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ViewPatterns #-}
56module Obelisk.Command.Deploy where
67
8+import Control.Lens
79import Control.Monad
10+import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try)
811import Control.Monad.IO.Class (liftIO)
912import Data.Bits
1013import Data.Default
@@ -18,6 +21,9 @@ import System.Environment (getEnvironment)
1821import System.FilePath
1922import System.Posix.Files
2023import System.Process (delegate_ctlc, env, proc)
24+import Text.URI (URI)
25+import qualified Text.URI as URI
26+import Text.URI.Lens
2127
2228import Obelisk.App (MonadObelisk)
2329import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, failWith, putLog, withSpinner)
@@ -26,30 +32,48 @@ import Obelisk.Command.Project
2632import Obelisk.Command.Thunk
2733import Obelisk.Command.Utils
2834
29−deployInit :: MonadObelisk m => ThunkPtr -> FilePath -> FilePath -> FilePath -> [String] -> m ()
30−deployInit thunkPtr configDir deployDir sshKeyPath hostnames = do
31− hasConfigDir <- liftIO $ do
32− createDirectoryIfMissing True deployDir
33− doesDirectoryExist configDir
34− localKey <- liftIO (doesFileExist sshKeyPath) >>= \case
35− False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath
36− True -> pure $ deployDir </> "ssh_key"
37− callProcessAndLogOutput (Notice, Error) $ proc "cp" [sshKeyPath, localKey]
38− liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode
39− liftIO $ writeFile (deployDir </> "backend_hosts") $ unlines hostnames
35+deployInit
36+ :: MonadObelisk m
37+ => ThunkPtr
38+ -> FilePath
39+ -> FilePath
40+ -> FilePath
41+ -> [String] -- ^ hostnames
42+ -> String -- ^ route
43+ -> String -- ^ admin email
44+ -> Bool -- ^ enable https
45+ -> m ()
46+deployInit thunkPtr configDir deployDir sshKeyPath hostnames route adminEmail enableHttps = do
47+ (hasConfigDir, localKey) <- withSpinner ("Preparing " <> T.pack deployDir) $ do
48+ hasConfigDir <- liftIO $ do
49+ createDirectoryIfMissing True deployDir
50+ doesDirectoryExist configDir
51+ localKey <- liftIO (doesFileExist sshKeyPath) >>= \case
52+ False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath
53+ True -> pure $ deployDir </> "ssh_key"
54+ callProcessAndLogOutput (Notice, Error) $
55+ proc "cp" [sshKeyPath, localKey]
56+ liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode
57+ return $ (hasConfigDir, localKey)
58+ withSpinner "Validating configuration" $ do
59+ void $ getHostFromRoute enableHttps route -- make sure that hostname is present
4060 forM_ hostnames $ \hostname -> do
4161 putLog Notice $ "Verifying host keys (" <> T.pack hostname <> ")"
62+ -- Note: we can't use a spinner here as this function will prompt the user.
4263 verifyHostKey (deployDir </> "backend_known_hosts") localKey hostname
43− when hasConfigDir $ do
44− callProcessAndLogOutput (Notice, Error) $ proc "cp"
45− [ "-r"
46− , "-T"
47− , configDir
48− , deployDir </> "config"
49− ]
50− liftIO $ createThunk (deployDir </> "src") thunkPtr
51− liftIO $ setupObeliskImpl deployDir
52− initGit deployDir
64+ when hasConfigDir $ withSpinner "Importing project configuration" $ do
65+ callProcessAndLogOutput (Notice, Error) $
66+ proc "cp" [ "-r" , "-T" , configDir , deployDir </> "config"]
67+ withSpinner "Writing deployment configuration" $ do
68+ writeDeployConfig deployDir "backend_hosts" $ unlines hostnames
69+ writeDeployConfig deployDir "enable_https" $ show enableHttps
70+ writeDeployConfig deployDir "admin_email" adminEmail
71+ writeDeployConfig deployDir ("config" </> "common" </> "route") $ route
72+ withSpinner "Creating source thunk (./src)" $ liftIO $ do
73+ createThunk (deployDir </> "src") thunkPtr
74+ setupObeliskImpl deployDir
75+ withSpinner ("Initializing git repository (" <> T.pack deployDir <> ")") $
76+ initGit deployDir
5377
5478setupObeliskImpl :: FilePath -> IO ()
5579setupObeliskImpl deployDir = do
@@ -59,8 +83,11 @@ setupObeliskImpl deployDir = do
5983
6084deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
6185deployPush deployPath getNixBuilders = do
62− let backendHosts = deployPath </> "backend_hosts"
63− host <- liftIO $ fmap (T.unpack . T.strip) $ T.readFile backendHosts
86+ host <- readDeployConfig deployPath "backend_hosts"
87+ adminEmail <- readDeployConfig deployPath "admin_email"
88+ enableHttps <- read <$> readDeployConfig deployPath "enable_https"
89+ route <- readDeployConfig deployPath $ "config" </> "common" </> "route"
90+ routeHost <- getHostFromRoute enableHttps route
6491 let srcPath = deployPath </> "src"
6592 build = do
6693 builders <- getNixBuilders
@@ -70,7 +97,12 @@ deployPush deployPath getNixBuilders = do
7097 , _target_attr = Just "server"
7198 }
7299 , _nixBuildConfig_outLink = OutLink_None
73− , _nixBuildConfig_args = pure $ Arg "hostName" host
100+ , _nixBuildConfig_args =
101+ [ strArg "hostName" host
102+ , strArg "adminEmail" adminEmail
103+ , strArg "routeHost" routeHost
104+ , boolArg "enableHttps" enableHttps
105+ ]
74106 , _nixBuildConfig_builders = builders
75107 }
76108 return $ listToMaybe $ lines buildOutput
@@ -114,6 +146,7 @@ deployPush deployPath getNixBuilders = do
114146 ["-C", deployPath, "add", "."]
115147 callProcessAndLogOutput (Debug, Error) $ proc "git"
116148 ["-C", deployPath, "commit", "-m", "New deployment"]
149+ putLog Notice $ "Deployed => " <> T.pack route
117150 where
118151 callProcess' envMap cmd args = do
119152 processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment
@@ -131,6 +164,14 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do
131164 result <- nixBuildAttrWithCache srcDir $ platform <> ".frontend"
132165 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs
133166
167+-- | Simplified deployment configuration mechanism. At one point we may revisit this.
168+writeDeployConfig :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
169+writeDeployConfig deployDir fname = liftIO . writeFile (deployDir </> fname)
170+
171+readDeployConfig :: MonadObelisk m => FilePath -> FilePath -> m String
172+readDeployConfig deployDir fname = liftIO $ do
173+ fmap (T.unpack . T.strip) $ T.readFile $ deployDir </> fname
174+
134175verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
135176verifyHostKey knownHostsPath keyPath hostName =
136177 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
@@ -145,3 +186,59 @@ sshArgs knownHostsPath keyPath askHostKeyCheck =
145186 , "-o", "StrictHostKeyChecking=" <> if askHostKeyCheck then "ask" else "yes"
146187 , "-i", keyPath
147188 ]
189+
190+-- common/route validation
191+-- TODO: move these to executable-config once the typed-config stuff is done.
192+
193+data InvalidRoute
194+ = InvalidRoute_NotHttps URI
195+ | InvalidRoute_MissingScheme URI
196+ | InvalidRoute_MissingHost URI
197+ | InvalidRoute_HasPort URI
198+ | InvalidRoute_HasPath URI
199+ deriving Show
200+
201+instance Exception InvalidRoute where
202+ displayException = \case
203+ InvalidRoute_MissingScheme uri -> route uri "must have an URI scheme"
204+ InvalidRoute_NotHttps uri -> route uri "must be HTTPS"
205+ InvalidRoute_MissingHost uri -> route uri "must contain a hostname"
206+ InvalidRoute_HasPort uri -> route uri "cannot specify port"
207+ InvalidRoute_HasPath uri -> route uri "cannot contain path"
208+ where
209+ route uri err = T.unpack $ "Route (" <> URI.render uri <> ") " <> err
210+
211+-- | Get the hostname from a https route
212+--
213+-- Fail if the route is invalid (i.e, no host present or scheme is not https)
214+getHostFromRoute
215+ :: MonadObelisk m
216+ => Bool -- ^ Ensure https?
217+ -> String
218+ -> m String
219+getHostFromRoute mustBeHttps route = do
220+ result :: Either InvalidRoute String <- try $ do
221+ validateCommonRouteAndGetHost mustBeHttps =<< URI.mkURI (T.strip $ T.pack route)
222+ either (failWith . T.pack . displayException) pure result
223+
224+validateCommonRouteAndGetHost
225+ :: (MonadThrow m, MonadObelisk m)
226+ => Bool -- ^ Ensure https?
227+ -> URI
228+ -> m String
229+validateCommonRouteAndGetHost mustBeHttps uri = do
230+ case uri ^? uriScheme of
231+ Just (Just (URI.unRText -> s)) -> case (mustBeHttps, s) of
232+ (False, _) -> pure ()
233+ (True, "https") -> pure ()
234+ _ -> throwM $ InvalidRoute_NotHttps uri
235+ _ -> throwM $ InvalidRoute_MissingScheme uri
236+ case uri ^. uriPath of
237+ [] -> pure ()
238+ _path -> throwM $ InvalidRoute_HasPath uri
239+ case uri ^? uriAuthority . _Right . authPort of
240+ Just (Just _port) -> throwM $ InvalidRoute_HasPort uri
241+ _ -> pure ()
242+ case uri ^? uriAuthority . _Right . authHost of
243+ Nothing -> throwM $ InvalidRoute_MissingHost uri
244+ Just sslHost -> return $ T.unpack $ URI.unRText sslHost