diff --git a/postgres-options.cabal b/postgres-options.cabal --- a/postgres-options.cabal +++ b/postgres-options.cabal @@ -1,5 +1,5 @@ name: postgres-options -version: 0.1.0.1 +version: 0.2.0.0 synopsis: An Options type representing options for postgres connections description: This package exports an Options type representing options for postgres connections homepage: https://github.com/jfischoff/postgres-options#readme @@ -16,10 +16,39 @@ library hs-source-dirs: src exposed-modules: Database.PostgreSQL.Simple.Options - build-depends: base >= 4.6 && < 5, bytestring + build-depends: + base >= 4.6 && < 5 + , bytestring + , split + , uri-bytestring + , generic-monoid default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind + default-extensions: + LambdaCase + , RecordWildCards + , GADTs + , OverloadedStrings + , DerivingStrategies + , DerivingVia + , TupleSections + , DeriveGeneric + +test-suite unit-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , hspec + , postgres-options + ghc-options: -Wall + -fno-warn-unused-do-bind + -threaded + -rtsopts + -with-rtsopts=-N + default-language: Haskell2010 + source-repository head type: git diff --git a/src/Database/PostgreSQL/Simple/Options.hs b/src/Database/PostgreSQL/Simple/Options.hs --- a/src/Database/PostgreSQL/Simple/Options.hs +++ b/src/Database/PostgreSQL/Simple/Options.hs @@ -1,115 +1,204 @@ -{-| A resuable optparse-applicative parser for creating a postgresql-simple - 'Connection' --} - -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-| A postgresql connection options type and related functions. -} module Database.PostgreSQL.Simple.Options ( Options(..) , defaultOptions - , toArgs , toConnectionString + , parseConnectionString ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BSC import Data.Maybe (Maybe, maybeToList) import Data.Typeable (Typeable) import GHC.Generics (Generic) +import Data.Monoid.Generic +import Data.List (intercalate) +import Data.List.Split (splitOn) +import Text.Read (readMaybe) +import URI.ByteString as URI +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Monoid +import Control.Monad ((<=<), foldM) +import Control.Applicative +-- | A postgresql connection options type. 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) - -toArgs :: Options -> [String] -toArgs Options {..} = - [ "--dbname=" <> oDbname - ] - ++ (("--host=" <>) <$> maybeToList oHost) - ++ (("--username=" <>) <$> maybeToList oUser) - ++ (("--password=" <>) <$> maybeToList oPassword) - ++ ((\x -> "--host=" <> show x) <$> maybeToList oPort) + { 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 stock (Show, Eq, Read, Ord, Generic, Typeable) + deriving Semigroup via GenericSemigroup Options + deriving Monoid via GenericMonoid Options +-- | Make a key value postgresql option string. 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 + $ maybeToPairStr "host" host + <> maybeToPairStr "hostaddr" hostaddr + <> maybeToPairStr "dbname" dbname + <> maybeToPair "port" port + <> maybeToPairStr "password" password + <> maybeToPairStr "user" user + <> maybeToPair "connect_timeout" connectTimeout + <> maybeToPairStr "client_encoding" clientEncoding + <> maybeToPairStr "options" options + <> maybeToPairStr "fallback_applicationName" fallbackApplicationName + <> maybeToPair "keepalives" keepalives + <> maybeToPair "keepalives_idle" keepalivesIdle + <> maybeToPair "keepalives_count" keepalivesCount + <> maybeToPairStr "sslmode" sslmode + <> maybeToPair "requiressl" requiressl + <> maybeToPair "sslcompression" sslcompression + <> maybeToPairStr "sslcert" sslcert + <> maybeToPairStr "sslkey" sslkey + <> maybeToPairStr "sslrootcert" sslrootcert + <> maybeToPairStr "requirepeer" requirepeer + <> maybeToPairStr "krbsrvname" krbsrvname + <> maybeToPairStr "gsslib" gsslib + <> maybeToPairStr "service" service where - maybeToPairStr :: String -> Maybe String -> [(String, String)] - maybeToPairStr k mv = (k,) <$> maybeToList mv + maybeToPairStr :: String -> Last String -> [(String, String)] + maybeToPairStr k mv = (k,) <$> maybeToList (getLast mv) - maybeToPair :: Show a => String -> Maybe a -> [(String, String)] - maybeToPair k mv = (\v -> (k, show v)) <$> maybeToList mv + maybeToPair :: Show a => String -> Last a -> [(String, String)] + maybeToPair k mv = (\v -> (k, show v)) <$> maybeToList (getLast mv) -defaultOptions :: String -> Options -defaultOptions dbName = Options { - oHost = Nothing - , oHostaddr = Nothing - , oPort = Nothing - , oUser = Nothing - , oPassword = Nothing - , oDbname = dbName - , oConnectTimeout = Nothing - , oClientEncoding = Nothing - , oOptions = Nothing - , oFallbackApplicationName = Nothing - , oKeepalives = Nothing - , oKeepalivesIdle = Nothing - , oKeepalivesCount = Nothing - , oSslmode = Nothing - , oRequiressl = Nothing - , oSslcompression = Nothing - , oSslcert = Nothing - , oSslkey = Nothing - , oSslrootcert = Nothing - , oRequirepeer = Nothing - , oKrbsrvname = Nothing - , oGsslib = Nothing - , oService = Nothing -} +{-| Default options. + + @ + defaultOptions :: Options + defaultOptions = mempty + { host = pure "localhost" + , port = pure 5432 + , user = pure "postgres" + , dbname = pure "postgres" + } + @ +-} +defaultOptions :: Options +defaultOptions = mempty + { host = pure "localhost" + , port = pure 5432 + , user = pure "postgres" + , dbname = pure "postgres" + } + +userInfoToptions :: UserInfo -> Options +userInfoToptions UserInfo {..} = mempty { user = return $ BSC.unpack uiUsername } <> if BS.null uiPassword + then mempty + else mempty { password = return $ BSC.unpack uiPassword } + +authorityToOptions :: Authority -> Options +authorityToOptions Authority {..} = maybe mempty userInfoToptions authorityUserInfo <> + mempty { host = return $ BSC.unpack $ hostBS authorityHost } <> + maybe mempty (\p -> mempty { port = return $ portNumber p }) authorityPort + +pathToptions :: ByteString -> Options +pathToptions 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 + +parseString :: String -> Maybe String +parseString x = readMaybe x <|> unSingleQuote x <|> Just x + +unSingleQuote :: String -> Maybe String +unSingleQuote (x : xs@(_ : _)) + | x == '\'' && last xs == '\'' = Just $ init xs + | otherwise = Nothing +unSingleQuote _ = Nothing + +keywordToptions :: String -> String -> Either String Options +keywordToptions 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 + +queryToptions :: URI.Query -> Either String Options +queryToptions Query {..} = foldM (\acc (k, v) -> fmap (mappend acc) $ keywordToptions (BSC.unpack k) $ BSC.unpack v) mempty queryPairs + +uriToptions :: URIRef Absolute -> Either String Options +uriToptions URI {..} = case schemeBS uriScheme of + "postgresql" -> do + queryParts <- queryToptions uriQuery + return $ maybe mempty authorityToOptions uriAuthority <> + pathToptions 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 Options +parseKeywords [] = Left "Failed to parse keywords" +parseKeywords x = fmap mconcat . mapM (uncurry keywordToptions <=< toTuple . splitOn "=") $ words x where + toTuple [k, v] = return (k, v) + toTuple xs = Left $ "invalid opts:" ++ show (intercalate "=" xs) + +-- | Parse a connection string. Can be in URI or keyword format. +parseConnectionString :: String -> Either String Options +parseConnectionString url = do + url' <- maybe (Left "failed to parse as string") Right $ parseString url + parseKeywords url' <|> (uriToptions =<< parseURIStr url') diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} +import Test.Hspec +import Database.PostgreSQL.Simple.Options + +main :: IO () +main = hspec $ describe "connection string parser" $ do + it "fails on empty" $ parseConnectionString "" `shouldBe` Left "MalformedScheme NonAlphaLeading" + + it "parses a single keyword" $ parseConnectionString "host=localhost" + `shouldBe` Right (mempty { host = return "localhost" }) + + it "parses all keywords" $ parseConnectionString + "host=localhost port=1234 user=jonathan password=open dbname=dev" `shouldBe` + Right (mempty + { host = return "localhost" + , port = return 1234 + , user = return "jonathan" + , password = return "open" + , dbname = return "dev" + }) + + it "parses host only connection string" $ parseConnectionString "postgresql://localhost" + `shouldBe` Right (mempty { host = return "localhost" }) + + it "parses all params" $ parseConnectionString "postgresql://jonathan:open@localhost:1234/dev" + `shouldBe` Right (mempty + { host = return "localhost" + , port = return 1234 + , user = return "jonathan" + , password = return "open" + , dbname = return "dev" + }) + + it "parses all params using query params" $ parseConnectionString "postgresql:///dev?host=localhost&port=1234" + `shouldBe` Right (mempty + { host = return "localhost" + , port = return 1234 + , dbname = return "dev" + }) + + it "decodes a unix port" $ parseConnectionString "postgresql://%2Fvar%2Flib%2Fpostgresql/dbname" + `shouldBe` Right (mempty + { host = return "/var/lib/postgresql" + , dbname = return "dbname" + })