@@ -2,9 +2,12 @@
2{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE ViewPatterns #-}
5module Obelisk.Command.Deploy where
6module Obelisk.Command.Deploy where
7import Control.Monad
9import Control.Monad
10+import Control.Monad.Catch (Exception (displayException), MonadThrow, throwM, try)
8import Control.Monad.IO.Class (liftIO)
11import Control.Monad.IO.Class (liftIO)
9import Data.Bits
12import Data.Bits
10import Data.Default
13import Data.Default
@@ -18,6 +21,9 @@ import System.Environment (getEnvironment)
18import System.FilePath
21import System.FilePath
19import System.Posix.Files
22import System.Posix.Files
20import System.Process (delegate_ctlc, env, proc)
23import System.Process (delegate_ctlc, env, proc)
25+import qualified Text.URI as URI
22import Obelisk.App (MonadObelisk)
28import Obelisk.App (MonadObelisk)
23import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, failWith, putLog, withSpinner)
29import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, failWith, putLog, withSpinner)
@@ -26,30 +32,48 @@ import Obelisk.Command.Project
26import Obelisk.Command.Thunk
32import Obelisk.Command.Thunk
27import Obelisk.Command.Utils
33import Obelisk.Command.Utils
29−deployInit :: MonadObelisk m => ThunkPtr -> FilePath -> FilePath -> FilePath -> [String] -> m ()
35+deployInit
41+ -> [String] -- ^ hostnames
43+ -> String -- ^ admin email
44+ -> Bool -- ^ enable https
30−deployInit thunkPtr configDir deployDir sshKeyPath hostnames = do
46+deployInit thunkPtr configDir deployDir sshKeyPath hostnames route adminEmail enableHttps = do
31− hasConfigDir <- liftIO $ do
47+ (hasConfigDir, localKey) <- withSpinner ("Preparing " <> T.pack deployDir) $ do
48+ hasConfigDir <- liftIO $ do
32− createDirectoryIfMissing True deployDir
49+ createDirectoryIfMissing True deployDir
33− doesDirectoryExist configDir
50+ doesDirectoryExist configDir
34− localKey <- liftIO (doesFileExist sshKeyPath) >>= \case
51+ localKey <- liftIO (doesFileExist sshKeyPath) >>= \case
35− False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath
52+ False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath
36− True -> pure $ deployDir </> "ssh_key"
53+ True -> pure $ deployDir </> "ssh_key"
37− callProcessAndLogOutput (Notice, Error) $ proc "cp" [sshKeyPath, localKey]
54+ callProcessAndLogOutput (Notice, Error) $
55+ proc "cp" [sshKeyPath, localKey]
38− liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode
56+ liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode
39− liftIO $ writeFile (deployDir </> "backend_hosts") $ unlines hostnames
57+ return $ (hasConfigDir, localKey)
58+ withSpinner "Validating configuration" $ do
59+ void $ getHostFromRoute enableHttps route -- make sure that hostname is present
40 forM_ hostnames $ \hostname -> do
60 forM_ hostnames $ \hostname -> do
41 putLog Notice $ "Verifying host keys (" <> T.pack hostname <> ")"
61 putLog Notice $ "Verifying host keys (" <> T.pack hostname <> ")"
62+ -- Note: we can't use a spinner here as this function will prompt the user.
42 verifyHostKey (deployDir </> "backend_known_hosts") localKey hostname
63 verifyHostKey (deployDir </> "backend_known_hosts") localKey hostname
43− when hasConfigDir $ do
64+ when hasConfigDir $ withSpinner "Importing project configuration" $ do
44− callProcessAndLogOutput (Notice, Error) $ proc "cp"
65+ callProcessAndLogOutput (Notice, Error) $
48− , deployDir </> "config"
66+ proc "cp" [ "-r" , "-T" , configDir , deployDir </> "config"]
49− ]
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
50− liftIO $ createThunk (deployDir </> "src") thunkPtr
73+ createThunk (deployDir </> "src") thunkPtr
51− liftIO $ setupObeliskImpl deployDir
74+ setupObeliskImpl deployDir
75+ withSpinner ("Initializing git repository (" <> T.pack deployDir <> ")") $
52− initGit deployDir
76+ initGit deployDir
54setupObeliskImpl :: FilePath -> IO ()
78setupObeliskImpl :: FilePath -> IO ()
55setupObeliskImpl deployDir = do
79setupObeliskImpl deployDir = do
@@ -59,8 +83,11 @@ setupObeliskImpl deployDir = do
60deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
84deployPush :: MonadObelisk m => FilePath -> m [String] -> m ()
61deployPush deployPath getNixBuilders = do
85deployPush deployPath getNixBuilders = do
62− let backendHosts = deployPath </> "backend_hosts"
86+ host <- readDeployConfig deployPath "backend_hosts"
63− host <- liftIO $ fmap (T.unpack . T.strip) $ T.readFile backendHosts
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
64 let srcPath = deployPath </> "src"
91 let srcPath = deployPath </> "src"
65 build = do
92 build = do
66 builders <- getNixBuilders
93 builders <- getNixBuilders
@@ -70,7 +97,12 @@ deployPush deployPath getNixBuilders = do
70 , _target_attr = Just "server"
97 , _target_attr = Just "server"
72 , _nixBuildConfig_outLink = OutLink_None
99 , _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
74 , _nixBuildConfig_builders = builders
106 , _nixBuildConfig_builders = builders
76 return $ listToMaybe $ lines buildOutput
108 return $ listToMaybe $ lines buildOutput
@@ -114,6 +146,7 @@ deployPush deployPath getNixBuilders = do
114 ["-C", deployPath, "add", "."]
146 ["-C", deployPath, "add", "."]
115 callProcessAndLogOutput (Debug, Error) $ proc "git"
147 callProcessAndLogOutput (Debug, Error) $ proc "git"
116 ["-C", deployPath, "commit", "-m", "New deployment"]
148 ["-C", deployPath, "commit", "-m", "New deployment"]
149+ putLog Notice $ "Deployed => " <> T.pack route
118 callProcess' envMap cmd args = do
151 callProcess' envMap cmd args = do
119 processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment
152 processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment
@@ -131,6 +164,14 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do
131 result <- nixBuildAttrWithCache srcDir $ platform <> ".frontend"
164 result <- nixBuildAttrWithCache srcDir $ platform <> ".frontend"
132 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs
165 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs
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)
171+readDeployConfig :: MonadObelisk m => FilePath -> FilePath -> m String
172+readDeployConfig deployDir fname = liftIO $ do
173+ fmap (T.unpack . T.strip) $ T.readFile $ deployDir </> fname
134verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
175verifyHostKey :: MonadObelisk m => FilePath -> FilePath -> String -> m ()
135verifyHostKey knownHostsPath keyPath hostName =
176verifyHostKey knownHostsPath keyPath hostName =
136 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
177 callProcessAndLogOutput (Notice, Warning) $ proc "ssh" $
@@ -145,3 +186,59 @@ sshArgs knownHostsPath keyPath askHostKeyCheck =
145 , "-o", "StrictHostKeyChecking=" <> if askHostKeyCheck then "ask" else "yes"
186 , "-o", "StrictHostKeyChecking=" <> if askHostKeyCheck then "ask" else "yes"
146 , "-i", keyPath
187 , "-i", keyPath
190+-- common/route validation
191+-- TODO: move these to executable-config once the typed-config stuff is done.
194+ = InvalidRoute_NotHttps URI
195+ | InvalidRoute_MissingScheme URI
196+ | InvalidRoute_MissingHost URI
197+ | InvalidRoute_HasPort URI
198+ | InvalidRoute_HasPath URI
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"
209+ route uri err = T.unpack $ "Route (" <> URI.render uri <> ") " <> err
211+-- | Get the hostname from a https route
213+-- Fail if the route is invalid (i.e, no host present or scheme is not https)
216+ => Bool -- ^ Ensure https?
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
224+validateCommonRouteAndGetHost
225+ :: (MonadThrow m, MonadObelisk m)
226+ => Bool -- ^ Ensure https?
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
238+ _path -> throwM $ InvalidRoute_HasPath uri
239+ case uri ^? uriAuthority . _Right . authPort of
240+ Just (Just _port) -> throwM $ InvalidRoute_HasPort uri
242+ case uri ^? uriAuthority . _Right . authHost of
243+ Nothing -> throwM $ InvalidRoute_MissingHost uri
244+ Just sslHost -> return $ T.unpack $ URI.unRText sslHost