diff --git a/server/src-lib/Hasura/Server/Init.hs b/server/src-lib/Hasura/Server/Init.hs index 7e493f4395fb4..1b38e133bff4e 100644 --- a/server/src-lib/Hasura/Server/Init.hs +++ b/server/src-lib/Hasura/Server/Init.hs @@ -5,15 +5,14 @@ module Hasura.Server.Init where import qualified Database.PG.Query as Q -import Network.URI import Options.Applicative import System.Exit (exitFailure) -import Text.Read (readMaybe) import qualified Data.Text as T import Hasura.Prelude import Hasura.RQL.DDL.Utils +import Hasura.Server.Utils data InitError = InitError !String @@ -65,8 +64,8 @@ parseRawConnInfo = value "" <> help "Password of the user" ) <*> optional (strOption ( long "database-url" <> - metavar "DataBase-URL" <> - help "Postgres database URL")) + metavar "DATABASE-URL" <> + help "Postgres database URL. Example postgres://foo:bar@example.com:2345/database")) <*> optional (strOption ( long "dbname" <> short 'd' <> metavar "NAME" <> @@ -79,105 +78,19 @@ connInfoErrModifier s = "Fatal Error : " ++ s mkConnInfo :: RawConnInfo -> Either String Q.ConnInfo mkConnInfo (RawConnInfo mHost mPort mUser pass mURL mDB opts) = case (mHost, mPort, mUser, mDB, mURL) of + (Just host, Just port, Just user, Just db, Nothing) -> return $ Q.ConnInfo host port user pass db opts - _ -> throwError "expecting all options for host, port, user and db" - -- (_, _, _, _, Just dbURL) -> parseURL dbURL mUser pass mPort mDB opts - -- _ -> throwError - -- "Invalid options. Expecting database connection params or database-url" - --- parseURL --- :: String --- -> Maybe String --- -> String --- -> Maybe Int --- -> Maybe String --- -> Maybe String --- -> Either String Q.ConnInfo --- parseURL urlS mUser password mPort mDB opts = --- case parseURI urlS of --- Nothing -> throwError "database-url is not valid" --- Just url -> do --- let uriAuth = uriAuthority url --- p = uriPath url --- parseURIAuth p uriAuth --- where --- parseURIAuth _ Nothing = throwError "Authorization info not found in database-url" --- parseURIAuth pt (Just authInfo) = do --- mDbName <- parsePath pt --- dbName <- case mDbName of --- Nothing -> case mDB of --- Nothing -> throwError --- "DB name not found in database-url. Expecting --dbname or -d flag" --- Just d -> return d --- Just d -> return d - --- (user, pass) <- parseUserInfo $ uriUserInfo authInfo --- let host = uriRegName authInfo --- port <- case parsePort $ uriPort authInfo of --- Just p -> return p --- Nothing -> case mPort of --- Nothing -> throwError --- "Port not found in datbase-url. Expecting --port or -p flag" --- Just p -> return p --- return $ Q.ConnInfo host port user pass dbName opts - --- parsePort "" = Nothing --- parsePort s = readMaybe $ tail s - --- parsePath "" = return Nothing --- parsePath "/" = return Nothing --- parsePath s = do --- let l = T.splitOn "/" $ T.pack s --- case l of --- [] -> return Nothing --- [_] -> return Nothing --- [_, b] -> return $ Just $ T.unpack b --- _ -> throwError $ --- "Invalid URL path. Expecting / in URL path." --- ++ " Occured " ++ s --- parseUserInfo ui = - -- let userI = init ui - -- (user, pass) = break (==':') userI - -- mNewPass = if null pass || (pass == ":") - -- then Nothing - -- else Just $ tail pass - -- newUser <- case user of - -- "" -> case mUser of - -- Nothing -> throwError - -- "User not found in database-url. Expecting --user or -u flag" - -- Just u -> return u - -- u -> return u - -- newPass <- case mNewPass of - -- Nothing -> return password - -- Just p -> return p - -- return (newUser, newPass) - -parseConnInfo :: Parser Q.ConnInfo -parseConnInfo = - Q.ConnInfo - <$> strOption ( long "host" <> - metavar "HOST" <> - help "Postgres server host" ) - <*> option auto ( long "port" <> - short 'p' <> - metavar "PORT" <> - help "Postgres server port" ) - <*> strOption ( long "user" <> - short 'u' <> - metavar "USER" <> - help "Database user name" ) - <*> strOption ( long "password" <> - short 'p' <> - metavar "PASSWORD" <> - value "" <> - help "Password of the user" ) - <*> strOption ( long "dbname" <> - short 'd' <> - metavar "NAME" <> - help "Database name to connect to" ) - <*> pure Nothing + (_, _, _, _, Just dbURL) -> maybe (throwError invalidUrlMsg) + return $ parseDatabaseUrl dbURL opts + _ -> throwError $ "Invalid options. " + ++ "Expecting all database connection params " + ++ "(host, port, user, dbname, password) or " + ++ "database-url" + where + invalidUrlMsg = "Invalid database-url. " + ++ "Example postgres://foo:bar@example.com:2345/database" readIsoLevel :: String -> Either String Q.TxIsolation readIsoLevel isoS = diff --git a/server/src-lib/Hasura/Server/Utils.hs b/server/src-lib/Hasura/Server/Utils.hs index 0ec2940db952b..0683a63c6bbbc 100644 --- a/server/src-lib/Hasura/Server/Utils.hs +++ b/server/src-lib/Hasura/Server/Utils.hs @@ -2,7 +2,12 @@ module Hasura.Server.Utils where -import qualified Data.Text as T +import qualified Database.PG.Query.Connection as Q + +import Data.List.Split +import Network.URI + +import qualified Data.Text as T import Hasura.Prelude dropAndSnakeCase :: T.Text -> T.Text @@ -22,3 +27,41 @@ userRoleHeader = "x-hasura-role" accessKeyHeader :: T.Text accessKeyHeader = "x-hasura-access-key" + +-- Parsing postgres database url +-- from: https://github.com/futurice/postgresql-simple-url/ +parseDatabaseUrl :: String -> Maybe String -> Maybe Q.ConnInfo +parseDatabaseUrl databaseUrl opts = parseURI databaseUrl >>= uriToConnectInfo opts + +uriToConnectInfo :: Maybe String -> URI -> Maybe Q.ConnInfo +uriToConnectInfo opts uri + | uriScheme uri /= "postgres:" && uriScheme uri /= "postgresql:" = Nothing + | otherwise = ($ Q.defaultConnInfo {Q.connOptions = opts}) <$> mkConnectInfo uri + +type ConnectInfoChange = Q.ConnInfo -> Q.ConnInfo + +mkConnectInfo :: URI -> Maybe ConnectInfoChange +mkConnectInfo uri = case uriPath uri of + ('/' : rest) | not (null rest) -> Just $ uriParameters uri + _ -> Nothing + +uriParameters :: URI -> ConnectInfoChange +uriParameters uri = (\info -> info { Q.connDatabase = tail $ uriPath uri }) . maybe id uriAuthParameters (uriAuthority uri) + +dropLast :: [a] -> [a] +dropLast [] = [] +dropLast [_] = [] +dropLast (x:xs) = x : dropLast xs + +uriAuthParameters :: URIAuth -> ConnectInfoChange +uriAuthParameters uriAuth = port . host . auth + where port = case uriPort uriAuth of + (':' : p) -> \info -> info { Q.connPort = read p } + _ -> id + host = case uriRegName uriAuth of + h -> \info -> info { Q.connHost = h } + auth = case splitOn ":" (uriUserInfo uriAuth) of + [""] -> id + [u] -> \info -> info { Q.connUser = dropLast u } + [u, p] -> \info -> info { Q.connUser = u, Q.connPassword = dropLast p } + _ -> id