postgres-options 0.1.0.1 → 0.2.0.0

raw patch · 3 files changed

+263/−100 lines, 3 filesdep +generic-monoiddep +hspecdep +postgres-optionsdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: generic-monoid, hspec, postgres-options, split, uri-bytestring

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• postgres-options.cabal +31/−2
• src/Database/PostgreSQL/Simple/Options.hs +187/−98
• test/Spec.hs +45/−0

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

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

@@ -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"+        })