module Hpgsql.Connection
  ( connect,
    connectOpts,
    defaultConnectOpts,
    withConnection,
    withConnectionOpts,
    closeGracefully,
    closeForcefully,
    ConnectionString (..),
    parseLibpqConnectionString,
    ResetConnectionOpts (..),
    resetConnectionState,
    renderLibpqConnectionString,
    refreshTypeInfoCache,
    resetTypeInfoCache,
    getParameterStatus,
    getBackendPid,
  )
where

import Control.Applicative
  ( (<|>),
  )
import Control.Monad
  ( unless,
    void,
    when,
  )
import Control.Monad.Trans.Except (runExceptT, throwE)
import Data.Attoparsec.Text
  ( Parser,
    char,
    endOfInput,
    parseOnly,
    peekChar,
    skipWhile,
    takeWhile1,
  )
import qualified Data.Attoparsec.Text as Parsec
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.Char as Char
import Data.Functor.Identity (Identity (..))
import Data.List
  ( sortOn,
  )
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)
import Hpgsql.Internal (closeForcefully, closeGracefully, connect, connectOpts, defaultConnectOpts, getBackendPid, getParameterStatus, refreshTypeInfoCache, resetConnectionState, resetTypeInfoCache, withConnection, withConnectionOpts)
import Hpgsql.InternalTypes (ConnectionString (..), ResetConnectionOpts (..))
import Network.URI
  ( URI (..),
    URIAuth (..),
    parseURI,
    unEscapeString,
  )
import Prelude hiding (takeWhile)

-- | Parses a libpq compatible connection string.
parseLibpqConnectionString :: Text -> Either String ConnectionString
parseLibpqConnectionString :: Text -> Either String ConnectionString
parseLibpqConnectionString =
  Parser ConnectionString -> Text -> Either String ConnectionString
forall a. Parser a -> Text -> Either String a
parseOnly (Parser ConnectionString
connStringParser Parser ConnectionString
-> Parser Text () -> Parser ConnectionString
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput)

-- | Renders a libpq compatible connection string.
renderLibpqConnectionString :: ConnectionString -> ByteString
renderLibpqConnectionString :: ConnectionString -> ByteString
renderLibpqConnectionString ConnectionString {Word16
Text
hostname :: Text
port :: Word16
user :: Text
password :: Text
database :: Text
options :: Text
options :: ConnectionString -> Text
database :: ConnectionString -> Text
password :: ConnectionString -> Text
user :: ConnectionString -> Text
port :: ConnectionString -> Word16
hostname :: ConnectionString -> Text
..} =
  ByteString -> [ByteString] -> ByteString
ByteString.intercalate ByteString
" " ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
    ((ByteString, ByteString) -> ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
kw, ByteString
v) -> ByteString
kw ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
v) [(ByteString, ByteString)]
mixedKwvps
  where
    mixedKwvps :: [(ByteString, ByteString)]
mixedKwvps =
      [Maybe (ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [Maybe a] -> [a]
catMaybes
        [ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
"user", Text -> ByteString
quote Text
user),
          (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just
            (ByteString
"host", Text -> ByteString
quote Text
hostname),
          (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just
            (ByteString
"dbname", Text -> ByteString
quote Text
database),
          (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
"password", Text -> ByteString
quote Text
password),
          (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
"port", Text -> ByteString
quote (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
port)),
          if Text -> Bool
Text.null Text
options then Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing else (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
"options", Text -> ByteString
quote Text
options)
        ]
    quote :: Text -> ByteString
quote Text
un =
      Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
        Text
"'"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"'" Text
"\\'" (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"\\" Text
"\\\\" Text
un)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"

-- | Parser that consumes any kind of Unicode space character, including \t, \n, \r, \f, \v.
skipAllWhiteSpace :: Parser ()
skipAllWhiteSpace :: Parser Text ()
skipAllWhiteSpace = (Char -> Bool) -> Parser Text ()
skipWhile Char -> Bool
Char.isSpace

-- | Parses a value using backslash as an escape char for any char that matches
-- the supplied predicate. Stops at and does not consume the first predicate-passing
-- char, and does not include escape chars in the returned value,
-- as one would expect.
parseWithEscapeCharProper :: (Char -> Bool) -> Parser Text
parseWithEscapeCharProper :: (Char -> Bool) -> Parser Text
parseWithEscapeCharProper Char -> Bool
untilc = do
  cs <- (Char -> Bool) -> Parser Text
Parsec.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
untilc Char
c))
  nextChar <- peekChar
  case nextChar of
    Maybe Char
Nothing -> Text -> Parser Text
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
cs
    Just Char
'\\' -> do
      Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
'\\'
      c <- Int -> Parser Text
Parsec.take Int
1
      rest <- parseWithEscapeCharProper untilc
      pure $ cs <> c <> rest
    Just Char
_ -> Text -> Parser Text
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
cs

eitherToMay :: Either a b -> Maybe b
eitherToMay :: forall a b. Either a b -> Maybe b
eitherToMay (Left a
_) = Maybe b
forall a. Maybe a
Nothing
eitherToMay (Right b
v) = b -> Maybe b
forall a. a -> Maybe a
Just b
v

-- | Parses a URI with scheme 'postgres' or 'postgresql', as per https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING.
-- The difference here is that URIs with a query string or with a fragment are not allowed.
uriConnParser :: Text -> Either String ConnectionString
uriConnParser :: Text -> Either String ConnectionString
uriConnParser Text
line = Identity (Either String ConnectionString)
-> Either String ConnectionString
forall a. Identity a -> a
runIdentity (Identity (Either String ConnectionString)
 -> Either String ConnectionString)
-> Identity (Either String ConnectionString)
-> Either String ConnectionString
forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT @String @_ @ConnectionString (ExceptT String Identity ConnectionString
 -> Identity (Either String ConnectionString))
-> ExceptT String Identity ConnectionString
-> Identity (Either String ConnectionString)
forall a b. (a -> b) -> a -> b
$ do
  case String -> Maybe URI
parseURI (Text -> String
Text.unpack Text
line) of
    Maybe URI
Nothing -> String -> ExceptT String Identity ConnectionString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Connection string is not a URI"
    Just URI {String
Maybe URIAuth
uriScheme :: String
uriAuthority :: Maybe URIAuth
uriPath :: String
uriQuery :: String
uriFragment :: String
uriFragment :: URI -> String
uriQuery :: URI -> String
uriPath :: URI -> String
uriAuthority :: URI -> Maybe URIAuth
uriScheme :: URI -> String
..} -> do
      Bool -> ExceptT String Identity () -> ExceptT String Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
        (Text -> Text
Text.toLower (String -> Text
Text.pack String
uriScheme) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"postgres:", Text
"postgresql:"])
        (ExceptT String Identity () -> ExceptT String Identity ())
-> ExceptT String Identity () -> ExceptT String Identity ()
forall a b. (a -> b) -> a -> b
$ String -> ExceptT String Identity ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
          String
"Connection string's URI scheme must be 'postgres' or 'postgresql'"
      case Maybe URIAuth
uriAuthority of
        Maybe URIAuth
Nothing ->
          String -> ExceptT String Identity ConnectionString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
            String
"Connection string must contain at least user and host"
        Just URIAuth {String
uriUserInfo :: String
uriRegName :: String
uriPort :: String
uriPort :: URIAuth -> String
uriRegName :: URIAuth -> String
uriUserInfo :: URIAuth -> String
..} -> do
          let database :: Text
database =
                String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Char -> String -> String
trimFirst Char
'/' String
uriPath
              hasQueryString :: Bool
hasQueryString = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uriQuery
              hasFragment :: Bool
hasFragment = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uriFragment
          Bool -> ExceptT String Identity () -> ExceptT String Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
Text.null Text
database) (ExceptT String Identity () -> ExceptT String Identity ())
-> ExceptT String Identity () -> ExceptT String Identity ()
forall a b. (a -> b) -> a -> b
$
            String -> ExceptT String Identity ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
              String
"Connection string must contain a database name"
          Bool -> ExceptT String Identity () -> ExceptT String Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasQueryString Bool -> Bool -> Bool
|| Bool
hasFragment) (ExceptT String Identity () -> ExceptT String Identity ())
-> ExceptT String Identity () -> ExceptT String Identity ()
forall a b. (a -> b) -> a -> b
$
            String -> ExceptT String Identity ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
              String
"Custom parameters are not supported in connection strings. Make sure your connection URI does not have a query string or query fragment"

          -- Ports are not mandatory and are defaulted to 5432 when not present
          let port :: Maybe Word16
port = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uriPort then Word16 -> Maybe Word16
forall a. a -> Maybe a
Just Word16
5432 else Maybe Word16
forall a. Maybe a
Nothing
          case Maybe Word16
port
            Maybe Word16 -> Maybe Word16 -> Maybe Word16
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either String Word16 -> Maybe Word16
forall a b. Either a b -> Maybe b
eitherToMay
              ( Parser Word16 -> Text -> Either String Word16
forall a. Parser a -> Text -> Either String a
parseOnly
                  (Parser Word16
forall a. Integral a => Parser a
Parsec.decimal Parser Word16 -> Parser Text () -> Parser Word16
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput)
                  (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char -> String -> String
trimFirst Char
':' String
uriPort)
              ) of
            Maybe Word16
Nothing ->
              String -> ExceptT String Identity ConnectionString
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE String
"Invalid port in connection string"
            Just Word16
parsedPort -> do
              let (String -> Text
Text.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
unEscapeString (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
trimLast Char
'@' -> Text
user, String -> Text
Text.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
unEscapeString (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
trimLast Char
'@' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
trimFirst Char
':' -> Text
password) =
                    (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
uriUserInfo
              ConnectionString -> ExceptT String Identity ConnectionString
forall a. a -> ExceptT String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ConnectionString
                  { hostname :: Text
hostname =
                      String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                        String -> String
unEscapeString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                          String -> String
unescapeIPv6 String
uriRegName,
                    port :: Word16
port = Word16
parsedPort,
                    Text
user :: Text
user :: Text
user,
                    Text
password :: Text
password :: Text
password,
                    Text
database :: Text
database :: Text
database,
                    options :: Text
options = Text
""
                  }
  where
    unescapeIPv6 :: String -> String
    unescapeIPv6 :: String -> String
unescapeIPv6 = Char -> String -> String
trimFirst Char
'[' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
trimLast Char
']'

    trimFirst :: Char -> String -> String
    trimFirst :: Char -> String -> String
trimFirst Char
c s :: String
s@(Char
c1 : String
cs) = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c1 then String
cs else String
s
    trimFirst Char
_ String
s = String
s

    trimLast :: Char -> String -> String
    trimLast :: Char -> String -> String
trimLast Char
c String
s = case Text -> Maybe (Text, Char)
Text.unsnoc (Text -> Maybe (Text, Char)) -> Text -> Maybe (Text, Char)
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s of
      Maybe (Text, Char)
Nothing -> String
s
      Just (Text
t, Char
lastChar) -> if Char
lastChar Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c then Text -> String
Text.unpack Text
t else String
s

keywordValueConnParser :: Text -> Either String ConnectionString
keywordValueConnParser :: Text -> Either String ConnectionString
keywordValueConnParser Text
line = Identity (Either String ConnectionString)
-> Either String ConnectionString
forall a. Identity a -> a
runIdentity (Identity (Either String ConnectionString)
 -> Either String ConnectionString)
-> Identity (Either String ConnectionString)
-> Either String ConnectionString
forall a b. (a -> b) -> a -> b
$ ExceptT String Identity ConnectionString
-> Identity (Either String ConnectionString)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String Identity ConnectionString
 -> Identity (Either String ConnectionString))
-> ExceptT String Identity ConnectionString
-> Identity (Either String ConnectionString)
forall a b. (a -> b) -> a -> b
$ do
  kvs <-
    ((Text, Text) -> Text) -> [(Text, Text)] -> [(Text, Text)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Text, Text) -> Text
forall a b. (a, b) -> a
fst
      ([(Text, Text)] -> [(Text, Text)])
-> ExceptT String Identity [(Text, Text)]
-> ExceptT String Identity [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text [(Text, Text)]
-> Text -> String -> ExceptT String Identity [(Text, Text)]
forall {m :: * -> *} {a} {e}.
Monad m =>
Parser Text a -> Text -> e -> ExceptT e m a
parseOrFail
        (Parser Text (Text, Text)
singleKeyVal Parser Text (Text, Text)
-> Parser Text -> Parser Text [(Text, Text)]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`Parsec.sepBy` (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
Char.isSpace)
        (Text -> Text
Text.strip Text
line)
        String
"Invalid connection string"
  ConnectionString
    <$> getVal "host" Nothing txtToString kvs
    <*> getVal "port" (Just 5432) Parsec.decimal kvs
    <*> getVal "user" Nothing txtToString kvs
    <*> getVal "password" (Just "") txtToString kvs
    <*> getVal "dbname" Nothing txtToString kvs
    <*> getVal "options" (Just "") txtToString kvs
  where
    getVal :: Text
-> Maybe a -> Parser Text a -> [(Text, Text)] -> ExceptT String m a
getVal Text
key Maybe a
def Parser Text a
parser [(Text, Text)]
pairs =
      case (((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Text
forall a b. (a, b) -> b
snd ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [(Text, Text)]
pairs, Maybe a
def) of
        ([], Maybe a
Nothing) ->
          String -> ExceptT String m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String m a) -> String -> ExceptT String m a
forall a b. (a -> b) -> a -> b
$
            String
"Connection string must contain a value for '"
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
key
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'"
        ([], Just a
v) -> a -> ExceptT String m a
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
        ([Text
vt], Maybe a
_) ->
          Parser Text a -> Text -> String -> ExceptT String m a
forall {m :: * -> *} {a} {e}.
Monad m =>
Parser Text a -> Text -> e -> ExceptT e m a
parseOrFail Parser Text a
parser Text
vt (String -> ExceptT String m a) -> String -> ExceptT String m a
forall a b. (a -> b) -> a -> b
$
            String
"Connection string key '"
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
key
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' is in an unrecognizable format"
        ([Text], Maybe a)
_ ->
          String -> ExceptT String m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String m a) -> String -> ExceptT String m a
forall a b. (a -> b) -> a -> b
$
            String
"Duplicate key '"
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
key
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' found in connection string."

    txtToString :: Parser Text
txtToString = Parser Text
Parsec.takeText
    parseOrFail :: Parser Text a -> Text -> e -> ExceptT e m a
parseOrFail Parser Text a
parser Text
txt e
errorMsg =
      case Parser Text a -> Text -> Either String a
forall a. Parser a -> Text -> Either String a
parseOnly (Parser Text a
parser Parser Text a -> Parser Text () -> Parser Text a
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput) Text
txt of
        Left String
_ -> e -> ExceptT e m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE e
errorMsg
        Right a
v -> a -> ExceptT e m a
forall a. a -> ExceptT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

    singleKeyVal :: Parser Text (Text, Text)
singleKeyVal = do
      key <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Bool -> Bool
not (Char -> Bool
Char.isSpace Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=')
      skipAllWhiteSpace
      void $ char '='
      skipAllWhiteSpace
      value <-
        takeQuotedString
          <|> parseWithEscapeCharProper
            (\Char
c -> Char -> Bool
Char.isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\')
          <|> pure ""
      pure (key, value)

    takeQuotedString :: Parser Text
takeQuotedString = do
      Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
'\''
      s <- (Char -> Bool) -> Parser Text
parseWithEscapeCharProper (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'')
      void $ char '\''
      pure s

-- | Parses a string in one of libpq allowed formats. See https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING.
-- The difference here is that only a subset of all connection parameters are allowed.
-- I wish this function existed in postgresql-simple or some form of it in postgresql-libpq, but if it does I couldn't find it.
connStringParser :: Parser ConnectionString
connStringParser :: Parser ConnectionString
connStringParser = do
  connStr <-
    (Char -> Bool) -> Parser Text
Parsec.takeWhile1 (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)
      Parser Text -> Parser Text -> Parser Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Text
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty connection string"
  -- Very poor connection string type handling here
  let connStrParser =
        if (Text
"postgres://" Text -> Text -> Bool
`Text.isPrefixOf` Text -> Text
Text.toLower Text
connStr)
          Bool -> Bool -> Bool
|| (Text
"postgresql://" Text -> Text -> Bool
`Text.isPrefixOf` Text -> Text
Text.toLower Text
connStr)
          then
            Text -> Either String ConnectionString
uriConnParser
          else
            Text -> Either String ConnectionString
keywordValueConnParser
  case connStrParser connStr of
    Left String
err ->
      String -> Parser ConnectionString
forall a. String -> Parser Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ConnectionString)
-> String -> Parser ConnectionString
forall a b. (a -> b) -> a -> b
$
        String
"Connection string is not a valid libpq connection string. A valid libpq connection string is either in the format 'postgres://username[:password]@host:port/database_name', with URI-encoded (percent-encoded) components except for the host and bracket-surround IPv6 addresses, or in the keyword value pairs format, e.g. 'dbname=database_name host=localhost user=postgres' with escaping for spaces, quotes or empty values. More info at https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING. Specific error: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
    Right ConnectionString
c -> ConnectionString -> Parser ConnectionString
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnectionString
c