{-# LANGUAGE RecordWildCards, LambdaCase, DeriveGeneric, DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, GADTs, OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Database.PostgreSQL.Simple.Options where
import Database.PostgreSQL.Simple
import Options.Applicative
import Text.Read
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString as BS
import GHC.Generics
import Options.Generic
import Data.Typeable
import Data.Either.Validation
import Data.Default
import URI.ByteString as URI
import Control.Monad
import Data.List.Split
import Data.List (intercalate)
import Generics.Deriving.Monoid
import Data.Char
import Data.Maybe
data Options = Options
{ oHost :: Maybe String
, oHostaddr :: Maybe String
, oPort :: Maybe Int
, oUser :: Maybe String
, oPassword :: Maybe String
, oDbname :: String
, oConnectTimeout :: Maybe Int
, oClientEncoding :: Maybe String
, oOptions :: Maybe String
, oFallbackApplicationName :: Maybe String
, oKeepalives :: Maybe Int
, oKeepalivesIdle :: Maybe Int
, oKeepalivesCount :: Maybe Int
, oSslmode :: Maybe String
, oRequiressl :: Maybe Int
, oSslcompression :: Maybe Int
, oSslcert :: Maybe String
, oSslkey :: Maybe String
, oSslrootcert :: Maybe String
, oRequirepeer :: Maybe String
, oKrbsrvname :: Maybe String
, oGsslib :: Maybe String
, oService :: Maybe String
} deriving (Show, Eq, Read, Ord, Generic, Typeable)
data PartialOptions = PartialOptions
{ host :: Last String
, hostaddr :: Last String
, port :: Last Int
, user :: Last String
, password :: Last String
, dbname :: Last String
, connectTimeout :: Last Int
, clientEncoding :: Last String
, options :: Last String
, fallbackApplicationName :: Last String
, keepalives :: Last Int
, keepalivesIdle :: Last Int
, keepalivesCount :: Last Int
, sslmode :: Last String
, requiressl :: Last Int
, sslcompression :: Last Int
, sslcert :: Last String
, sslkey :: Last String
, sslrootcert :: Last String
, requirepeer :: Last String
, krbsrvname :: Last String
, gsslib :: Last String
, service :: Last String
} deriving (Show, Eq, Read, Ord, Generic, Typeable)
instance ParseRecord PartialOptions where
parseRecord = (option (eitherReader parseConnectionString) (long "connectString"))
<|> parseRecordWithModifiers defaultModifiers
instance Semigroup PartialOptions where
(<>) = gmappenddefault
instance Monoid PartialOptions where
mempty = gmemptydefault
mappend = (<>)
underscoreModifiers :: Modifiers
underscoreModifiers = Modifiers lispCase lispCase (const Nothing)
where
lispCase = dropWhile (== '_') . (>>= lower) . dropWhile (== '_')
lower c | isUpper c = ['_', toLower c]
| otherwise = [c]
unSingleQuote :: String -> Maybe String
unSingleQuote (x : xs@(_ : _))
| x == '\'' && last xs == '\'' = Just $ init xs
| otherwise = Nothing
unSingleQuote _ = Nothing
parseString :: String -> Maybe String
parseString x = readMaybe x <|> unSingleQuote x <|> Just x
mkLast :: a -> Last a
mkLast = Last . Just
instance Default PartialOptions where
def = mempty
{ host = mkLast $ connectHost defaultConnectInfo
, port = mkLast $ fromIntegral $ connectPort defaultConnectInfo
, user = mkLast $ connectUser defaultConnectInfo
, password = mkLast $ connectPassword defaultConnectInfo
, dbname = mkLast $ connectDatabase defaultConnectInfo
}
getOption :: String -> Last a -> Validation [String] a
getOption optionName = \case
Last (Just x) -> pure x
Last Nothing -> Data.Either.Validation.Failure
["Missing " ++ optionName ++ " option"]
getLast' :: Applicative f => Last a -> f (Maybe a)
getLast' = pure . getLast
completeOptions :: PartialOptions -> Either [String] Options
completeOptions PartialOptions {..} = validationToEither $ do
Options <$> getLast' host
<*> getLast' hostaddr
<*> (fmap fromIntegral <$> getLast' port)
<*> getLast' user
<*> getLast' password
<*> getOption "dbname" dbname
<*> getLast' connectTimeout
<*> getLast' clientEncoding
<*> getLast' options
<*> getLast' fallbackApplicationName
<*> getLast' keepalives
<*> getLast' keepalivesIdle
<*> getLast' keepalivesCount
<*> getLast' sslmode
<*> getLast' requiressl
<*> getLast' sslcompression
<*> getLast' sslcert
<*> getLast' sslkey
<*> getLast' sslrootcert
<*> getLast' requirepeer
<*> getLast' krbsrvname
<*> getLast' gsslib
<*> getLast' service
maybeToPairStr :: String -> Maybe String -> [(String, String)]
maybeToPairStr k mv = (\v -> (k, v)) <$> maybeToList mv
maybeToPair :: Show a => String -> Maybe a -> [(String, String)]
maybeToPair k mv = (\v -> (k, show v)) <$> maybeToList mv
toConnectionString :: Options -> ByteString
toConnectionString Options {..} = BSC.pack $ unwords $ map (\(k, v) -> k <> "=" <> v)
$ maybeToPairStr "host" oHost
<> maybeToPairStr "hostaddr" oHostaddr
<> [ ("dbname", oDbname)
]
<> maybeToPair "port" oPort
<> maybeToPairStr "password" oPassword
<> maybeToPairStr "user" oUser
<> maybeToPair "connect_timeout" oConnectTimeout
<> maybeToPairStr "client_encoding" oClientEncoding
<> maybeToPairStr "options" oOptions
<> maybeToPairStr "fallback_applicationName" oFallbackApplicationName
<> maybeToPair "keepalives" oKeepalives
<> maybeToPair "keepalives_idle" oKeepalivesIdle
<> maybeToPair "keepalives_count" oKeepalivesCount
<> maybeToPairStr "sslmode" oSslmode
<> maybeToPair "requiressl" oRequiressl
<> maybeToPair "sslcompression" oSslcompression
<> maybeToPairStr "sslcert" oSslcert
<> maybeToPairStr "sslkey" oSslkey
<> maybeToPairStr "sslrootcert" oSslrootcert
<> maybeToPairStr "requirepeer" oRequirepeer
<> maybeToPairStr "krbsrvname" oKrbsrvname
<> maybeToPairStr "gsslib" oGsslib
<> maybeToPairStr "service" oService
completeParser :: Parser Options
completeParser =
fmap (either (error . unlines) id . completeOptions . mappend def) parseRecord
run :: Options -> IO Connection
run = connectPostgreSQL . toConnectionString
userInfoToPartialOptions :: UserInfo -> PartialOptions
userInfoToPartialOptions UserInfo {..} = mempty { user = return $ BSC.unpack uiUsername } <> if BS.null uiPassword
then mempty
else mempty { password = return $ BSC.unpack uiPassword }
autorityToPartialOptions :: Authority -> PartialOptions
autorityToPartialOptions Authority {..} = maybe mempty userInfoToPartialOptions authorityUserInfo <>
mempty { host = return $ BSC.unpack $ hostBS authorityHost } <>
maybe mempty (\p -> mempty { port = return $ portNumber p }) authorityPort
pathToPartialOptions :: ByteString -> PartialOptions
pathToPartialOptions path = case drop 1 $ BSC.unpack path of
"" -> mempty
x -> mempty {dbname = return x }
parseInt :: String -> String -> Either String Int
parseInt msg v = maybe (Left (msg <> " value of: " <> v <> " is not a number")) Right $
readMaybe v
keywordToPartialOptions :: String -> String -> Either String PartialOptions
keywordToPartialOptions k v = case k of
"host" -> return $ mempty { host = return $ v }
"hostaddress" -> return $ mempty { hostaddr = return $ v }
"port" -> do
portValue <- parseInt "port" v
return $ mempty { port = return portValue }
"user" -> return $ mempty { user = return v }
"password" -> return $ mempty { password = return v }
"dbname" -> return $ mempty { dbname = return v}
"connect_timeout" -> do
x <- parseInt "connect_timeout" v
return $ mempty { connectTimeout = return x }
"client_encoding" -> return $ mempty { clientEncoding = return v }
"options" -> return $ mempty { options = return v }
"fallback_applicationName" -> return $ mempty { fallbackApplicationName = return v }
"keepalives" -> do
x <- parseInt "keepalives" v
return $ mempty { keepalives = return x }
"keepalives_idle" -> do
x <- parseInt "keepalives_idle" v
return $ mempty { keepalivesIdle = return x }
"keepalives_count" -> do
x <- parseInt "keepalives_count" v
return $ mempty { keepalivesCount = return x }
"sslmode" -> return $ mempty { sslmode = return v }
"requiressl" -> do
x <- parseInt "requiressl" v
return $ mempty { requiressl = return x }
"sslcompression" -> do
x <- parseInt "sslcompression" v
return $ mempty { sslcompression = return x }
"sslcert" -> return $ mempty { sslcert = return v }
"sslkey" -> return $ mempty { sslkey = return v }
"sslrootcert" -> return $ mempty { sslrootcert = return v }
"requirepeer" -> return $ mempty { requirepeer = return v }
"krbsrvname" -> return $ mempty { krbsrvname = return v }
"gsslib" -> return $ mempty { gsslib = return v }
"service" -> return $ mempty { service = return v }
x -> Left $ "Unrecongnized option: " ++ show x
queryToPartialOptions :: URI.Query -> Either String PartialOptions
queryToPartialOptions Query {..} = foldM (\acc (k, v) -> fmap (mappend acc) $ keywordToPartialOptions (BSC.unpack k) $ BSC.unpack v) mempty queryPairs
uriToOptions :: URIRef Absolute -> Either String PartialOptions
uriToOptions URI {..} = case schemeBS uriScheme of
"postgresql" -> do
queryParts <- queryToPartialOptions uriQuery
return $ maybe mempty autorityToPartialOptions uriAuthority <>
pathToPartialOptions uriPath <> queryParts
x -> Left $ "Wrong protocol. Expected \"postgresql\" but got: " ++ show x
parseURIStr :: String -> Either String (URIRef Absolute)
parseURIStr = left show . parseURI strictURIParserOptions . BSC.pack where
left f = \case
Left x -> Left $ f x
Right x -> Right x
parseKeywords :: String -> Either String PartialOptions
parseKeywords [] = Left "Failed to parse keywords"
parseKeywords x = fmap mconcat . mapM (uncurry keywordToPartialOptions <=< toTuple . splitOn "=") $ words x where
toTuple [k, v] = return (k, v)
toTuple xs = Left $ "invalid opts:" ++ show (intercalate "=" xs)
parseConnectionString :: String -> Either String PartialOptions
parseConnectionString url = do
url' <- maybe (Left "failed to parse as string") Right $ parseString url
parseKeywords url' <|> (uriToOptions =<< parseURIStr url')
toArgs :: Options -> [String]
toArgs Options {..} =
[ "--dbname=" <> oDbname
]
++ (("--host=" <>) <$> maybeToList oHost)
++ (("--username=" <>) <$> maybeToList oUser)
++ (("--password=" <>) <$> maybeToList oPassword)
++ ((\x -> "--host=" <> show x) <$> maybeToList oPort)