support optional parameters in database url (close #1709) (#2344)

server/src-lib/Hasura/Server/Init.hs

@@ -3,10 +3,6 @@ module Hasura.Server.Init where
 
 import qualified Database.PG.Query                as Q
 
-import           Data.Char                        (toLower)
-import           Network.Wai.Handler.Warp         (HostPreference)
-import           Options.Applicative
-
 import qualified Data.Aeson                       as J
 import qualified Data.Aeson.Casing                as J
 import qualified Data.Aeson.TH                    as J
@@ -14,9 +10,15 @@ import qualified Data.ByteString.Lazy.Char8       as BLC
 import qualified Data.HashSet                     as Set
 import qualified Data.String                      as DataString
 import qualified Data.Text                        as T
+import qualified Data.Text.Encoding               as TE
+import qualified Text.PrettyPrint.ANSI.Leijen     as PP
+
+import           Data.Char                        (toLower)
+import           Network.Wai.Handler.Warp         (HostPreference)
+import           Options.Applicative
+
 import qualified Hasura.GraphQL.Execute.LiveQuery as LQ
 import qualified Hasura.Logging                   as L
-import qualified Text.PrettyPrint.ANSI.Leijen     as PP
 
 import           Hasura.Prelude
 import           Hasura.RQL.Types                 (RoleName (..),
@@ -26,6 +28,7 @@ import           Hasura.Server.Auth
 import           Hasura.Server.Cors
 import           Hasura.Server.Logging
 import           Hasura.Server.Utils
+import           Network.URI                      (parseURI)
 
 newtype InstanceId
   = InstanceId { getInstanceId :: Text }
@@ -655,24 +658,22 @@ parseRawConnInfo =
 connInfoErrModifier :: String -> String
 connInfoErrModifier s = "Fatal Error : " ++ s
 
-mkConnInfo ::RawConnInfo -> Either String Q.ConnInfo
+mkConnInfo :: RawConnInfo -> Either String Q.ConnInfo
 mkConnInfo (RawConnInfo mHost mPort mUser password mURL mDB opts mRetries) =
+  Q.ConnInfo retries <$>
   case (mHost, mPort, mUser, mDB, mURL) of
 
     (Just host, Just port, Just user, Just db, Nothing) ->
-      return $ Q.ConnInfo host port user password db opts retries
+      return $ Q.CDOptions $ Q.ConnOptions host port user password db opts
 
-    (_, _, _, _, Just dbURL) -> maybe (throwError invalidUrlMsg)
-                                withRetries $ parseDatabaseUrl dbURL opts
+    (_, _, _, _, Just dbURL) ->
+      return $ Q.CDDatabaseURI $ TE.encodeUtf8 $ T.pack dbURL
     _ -> throwError $ "Invalid options. "
                     ++ "Expecting all database connection params "
                     ++ "(host, port, user, dbname, password) or "
                     ++ "database-url (HASURA_GRAPHQL_DATABASE_URL)"
   where
     retries = fromMaybe 1 mRetries
-    withRetries ci = return $ ci{Q.connRetries = retries}
-    invalidUrlMsg = "Invalid database-url (HASURA_GRAPHQL_DATABASE_URL). "
-                    ++ "Example postgres://foo:bar@example.com:2345/database"
 
 parseTxIsolation :: Parser (Maybe Q.TxIsolation)
 parseTxIsolation = optional $
@@ -959,15 +960,28 @@ parseLogLevel = optional $
 
 -- Init logging related
 connInfoToLog :: Q.ConnInfo -> StartupLog
-connInfoToLog (Q.ConnInfo host port user _ db _ retries) =
+connInfoToLog connInfo =
   StartupLog L.LevelInfo "postgres_connection" infoVal
   where
-    infoVal = J.object [ "host" J..= host
-                       , "port" J..= port
-                       , "user" J..= user
-                       , "database" J..= db
-                       , "retries" J..= retries
-                       ]
+    Q.ConnInfo retries details = connInfo
+    infoVal = case details of
+      Q.CDDatabaseURI uri -> mkDBUriLog $ T.unpack $ bsToTxt uri
+      Q.CDOptions co      ->
+        J.object [ "host" J..= Q.connHost co
+                 , "port" J..= Q.connPort co
+                 , "user" J..= Q.connUser co
+                 , "database" J..= Q.connDatabase co
+                 , "retries" J..= retries
+                 ]
+
+    mkDBUriLog uri =
+      case show <$> parseURI uri of
+        Nothing -> J.object
+          [ "error" J..= ("parsing database url failed" :: String)]
+        Just s  -> J.object
+          [ "retries" J..= retries
+          , "database_url" J..= s
+          ]
 
 serveOptsToLog :: ServeOptions -> StartupLog
 serveOptsToLog so =

server/src-lib/Hasura/Server/PGDump.hs

@@ -48,7 +48,8 @@ execPGDump b ci = do
         ExitSuccess   -> Right $ CS.cs (clean stdOut)
         ExitFailure _ -> Left $ CS.cs stdErr
 
-    opts = Q.pgConnString ci : "--encoding=utf8" : prbOpts b
+    connString = T.unpack $ bsToTxt $ Q.pgConnString $ Q.ciDetails ci
+    opts = connString : "--encoding=utf8" : prbOpts b
 
     clean str
       | fromMaybe False (prbCleanOutput b) =

server/src-lib/Hasura/Server/Utils.hs

@@ -1,31 +1,27 @@
 module Hasura.Server.Utils where
 
-import qualified Database.PG.Query.Connection as Q
-
 import           Data.Aeson
 import           Data.Char
-import           Data.List                    (find)
-import           Data.List.Split
+import           Data.List                  (find)
 import           Data.Time.Clock
-import           Network.URI
 import           System.Environment
 import           System.Exit
 import           System.Process
 
-import qualified Data.ByteString              as B
-import qualified Data.CaseInsensitive         as CI
-import qualified Data.HashSet                 as Set
-import qualified Data.Text                    as T
-import qualified Data.Text.Encoding           as TE
-import qualified Data.Text.IO                 as TI
-import qualified Data.UUID                    as UUID
-import qualified Data.UUID.V4                 as UUID
-import qualified Language.Haskell.TH.Syntax   as TH
-import qualified Network.HTTP.Client          as HC
-import qualified Network.HTTP.Types           as HTTP
-import qualified Text.Ginger                  as TG
-import qualified Text.Regex.TDFA              as TDFA
-import qualified Text.Regex.TDFA.ByteString   as TDFA
+import qualified Data.ByteString            as B
+import qualified Data.CaseInsensitive       as CI
+import qualified Data.HashSet               as Set
+import qualified Data.Text                  as T
+import qualified Data.Text.Encoding         as TE
+import qualified Data.Text.IO               as TI
+import qualified Data.UUID                  as UUID
+import qualified Data.UUID.V4               as UUID
+import qualified Language.Haskell.TH.Syntax as TH
+import qualified Network.HTTP.Client        as HC
+import qualified Network.HTTP.Types         as HTTP
+import qualified Text.Ginger                as TG
+import qualified Text.Regex.TDFA            as TDFA
+import qualified Text.Regex.TDFA.ByteString as TDFA
 
 import           Hasura.Prelude
 
@@ -72,44 +68,6 @@ getRequestId headers =
     Nothing    -> RequestId <$> liftIO generateFingerprint
     Just reqId -> return $ RequestId $ bsToTxt reqId
 
--- 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 = unEscapeString h }
-        auth = case splitOn ":" (uriUserInfo uriAuth) of
-                 [""]   -> id
-                 [u]    -> \info -> info { Q.connUser = unEscapeString $ dropLast u }
-                 [u, p] -> \info -> info { Q.connUser = unEscapeString u, Q.connPassword = unEscapeString $ dropLast p }
-                 _      -> id
-
 -- Get an env var during compile time
 getValFromEnvOrScript :: String -> String -> TH.Q TH.Exp
 getValFromEnvOrScript n s = do