hasura · 0x777 · Jun 28, 2018 · Jun 28, 2018 · Jun 28, 2018 · Jun 28, 2018
@@ -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 /<db-name> 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 =

@@ -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