postgresql-simple-opts 0.2.0.2 → 0.3.0.0

raw patch · 3 files changed

+353/−146 lines, 3 filesdep +generic-derivingdep +splitdep +uri-bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: generic-deriving, split, uri-bytestring

API changes (from Hackage documentation)

Files

• postgresql-simple-opts.cabal +6/−2
• src/Database/PostgreSQL/Simple/Options.hs +239/−81
• test/Spec.hs +108/−63

@@ -1,7 +1,7 @@ name:                postgresql-simple-opts-version:             0.2.0.2+version:             0.3.0.0 synopsis:            An optparse-applicative parser for postgresql-simple's connection options-description:         This package exports a optparse-applicative parser and type for postgresql-simple's ConnectInfo and connection string.+description:         This package exports a optparse-applicative parser and type for postgresql-simple's Options and connection string. homepage:            https://github.com/jfischoff/postgresql-simple-opts#readme license:             BSD3 license-file:        LICENSE@@ -23,6 +23,9 @@                , either                , optparse-generic >= 1.0.1 && <1.3                , data-default+               , split+               , uri-bytestring+               , generic-deriving   default-language:    Haskell2010   ghc-options: -Wall                -fno-warn-unused-do-bind@@ -37,6 +40,7 @@                      , postgresql-simple                      , optparse-applicative                      , bytestring+                     , data-default   ghc-options: -Wall                -fno-warn-unused-do-bind                -threaded

@@ -2,49 +2,99 @@    'Connection' -} {-# LANGUAGE RecordWildCards, LambdaCase, DeriveGeneric, DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-}+{-# 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.String import Data.Monoid 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 --- | An optional version of 'ConnectInfo'. This includes an instance of+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)+-- | An optional version of 'Options'. This includes an instance of -- | 'ParseRecord' which provides the optparse-applicative Parser.-data PartialConnectInfo = PartialConnectInfo-  { host     :: Last String-  , port     :: Last Int-  , user     :: Last String-  , password :: Last String-  , database :: Last String+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 PartialConnectInfo+instance ParseRecord PartialOptions where+  parseRecord = (option (eitherReader parseConnectionString) (long "connectString"))+    <|> parseRecordWithModifiers defaultModifiers -instance Monoid PartialConnectInfo where-  mempty = PartialConnectInfo (Last Nothing) (Last Nothing)-                              (Last Nothing) (Last Nothing)-                              (Last Nothing)-  mappend x y = PartialConnectInfo-    { host     = host     x <> host     y-    , port     = port     x <> port     y-    , user     = user     x <> user     y-    , password = password x <> password y-    , database = database x <> database y-    }+instance Monoid PartialOptions where+  mempty = gmemptydefault+  mappend = gmappenddefault -newtype ConnectString = ConnectString-  { connectString :: ByteString-  } deriving ( Show, Eq, Read, Ord, Generic, Typeable, IsString )+-- Copied from Options.Generic source code+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@@ -54,78 +104,88 @@ parseString :: String -> Maybe String parseString x = readMaybe x <|> unSingleQuote x <|> Just x -instance ParseRecord ConnectString where-  parseRecord =  fmap (ConnectString . BSC.pack)-              $  option ( eitherReader-                        $ maybe (Left "Impossible!") Right-                        . parseString-                        )-                        (long "connectString")--data PartialOptions-  = POConnectString      ConnectString-  | POPartialConnectInfo PartialConnectInfo-  deriving (Show, Eq, Read, Generic, Typeable)--instance Monoid PartialOptions where-    mempty = POPartialConnectInfo mempty-    mappend a b = case (a, b) of-        (POConnectString x, _) -> POConnectString x-        (POPartialConnectInfo x, POPartialConnectInfo y) ->-            POPartialConnectInfo $ x <> y-        (POPartialConnectInfo _, POConnectString x) -> POConnectString x--instance ParseRecord PartialOptions where-  parseRecord-    =  fmap POConnectString      parseRecord-   <|> fmap POPartialConnectInfo parseRecord---- | The main parser to reuse.-parser :: Parser PartialOptions-parser = parseRecord--data Options-  = OConnectString ByteString-  | OConnectInfo   ConnectInfo-  deriving (Show, Eq, Read, Generic, Typeable)- mkLast :: a -> Last a mkLast = Last . Just --- | The 'PartialConnectInfo' version of 'defaultConnectInfo'-instance Default PartialConnectInfo where-    def = PartialConnectInfo+-- | The 'PartialOptions' version of 'defaultOptions'+instance Default PartialOptions where+    def = mempty       { host     = mkLast $                connectHost     defaultConnectInfo       , port     = mkLast $ fromIntegral $ connectPort     defaultConnectInfo       , user     = mkLast $                connectUser     defaultConnectInfo       , password = mkLast $                connectPassword defaultConnectInfo-      , database = mkLast $                connectDatabase defaultConnectInfo+      , dbname = mkLast $                  connectDatabase defaultConnectInfo       } -instance Default PartialOptions where-    def = POPartialConnectInfo def- getOption :: String -> Last a -> Validation [String] a getOption optionName = \case     Last (Just x) -> pure x     Last Nothing  -> Data.Either.Validation.Failure         ["Missing " ++ optionName ++ " option"] -completeConnectInfo :: PartialConnectInfo -> Either [String] ConnectInfo-completeConnectInfo PartialConnectInfo {..} = validationToEither $ do-  ConnectInfo <$> getOption "host"     host-              <*> (fromIntegral <$> getOption "port" port)-              <*> getOption "user"     user-              <*> getOption "password" password-              <*> getOption "database" database+getLast' :: Applicative f => Last a -> f (Maybe a)+getLast' = pure . getLast --- | mappend with 'defaultPartialConnectInfo' if necessary to create all---   options completeOptions :: PartialOptions -> Either [String] Options-completeOptions = \case-  POConnectString   (ConnectString x) -> Right $ OConnectString x-  POPartialConnectInfo x              -> OConnectInfo <$> completeConnectInfo x+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++ -- | Useful for testing or if only Options are needed. completeParser :: Parser Options completeParser =@@ -133,6 +193,104 @@  -- | Create a connection with an 'Option' run :: Options -> IO Connection-run = \case-  OConnectString connString -> connectPostgreSQL connString-  OConnectInfo   connInfo   -> connect           connInfo+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)+

@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings, CPP #-} import Test.Hspec import Database.PostgreSQL.Simple.Options-import Database.PostgreSQL.Simple import System.Environment import Options.Applicative import System.Exit+import Data.Default #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif@@ -13,76 +13,121 @@ testParser = execParser $ info completeParser mempty  main :: IO ()-main = hspec $ describe "Options Parser" $ do-  it "parses all options" $ do-    let testArgs = [ "--host=example.com"-                   , "--port=1234"-                   , "--user=nobody"-                   , "--password=everytimeiclosemyeyes"-                   , "--database=future"-                   ]+main = hspec $ do+  describe "Options Parser" $ do+    it "parses all options" $ do+      let testArgs = [ "--host=example.com"+                     , "--port=1234"+                     , "--user=nobody"+                     , "--password=everytimeiclosemyeyes"+                     , "--dbname=future"+                     ] -        expected = OConnectInfo $ ConnectInfo-                   { connectHost     = "example.com"-                   , connectPort     = 1234-                   , connectUser     = "nobody"-                   , connectPassword = "everytimeiclosemyeyes"-                   , connectDatabase = "future"-                   }+          expected = completeOptions $ mempty+                     { host     = return "example.com"+                     , port     = return 1234+                     , user     = return "nobody"+                     , password = return "everytimeiclosemyeyes"+                     , dbname   = return "future"+                     } -    actual <- withArgs testArgs testParser-    actual `shouldBe` expected+      actual <- withArgs testArgs testParser+      Right actual `shouldBe` expected -  it "parses some and uses defaults for others" $ do-    let testArgs = [ "--user=nobody"-                   , "--password=everytimeiclosemyeyes"-                   , "--database=future"-                   ]+    it "parses some and uses defaults for others" $ do+      let testArgs = [ "--user=nobody"+                     , "--password=everytimeiclosemyeyes"+                     , "--dbname=future"+                     ] -        expected = OConnectInfo $ ConnectInfo-                   { connectHost     = "127.0.0.1"-                   , connectPort     = 5432-                   , connectUser     = "nobody"-                   , connectPassword = "everytimeiclosemyeyes"-                   , connectDatabase = "future"-                   }+          expected = completeOptions $ mempty+                     { host     = return "127.0.0.1"+                     , port     = return 5432+                     , user     = return "nobody"+                     , password = return "everytimeiclosemyeyes"+                     , dbname   = return "future"+                     } -    actual <- withArgs testArgs testParser-    actual `shouldBe` expected+      actual <- withArgs testArgs testParser+      Right actual `shouldBe` expected -  it "parses no options and gives defaults" $ do-    let expected = OConnectInfo $ ConnectInfo-                   { connectHost     = "127.0.0.1"-                   , connectPort     = 5432-                   , connectUser     = "postgres"-                   , connectPassword = ""-                   , connectDatabase = ""-                   }+    it "parses no options and gives defaults" $ do+      let expected = completeOptions $ mempty+                     { host     = return "127.0.0.1"+                     , port     = return 5432+                     , user     = return "postgres"+                     , password = return ""+                     , dbname   = return ""+                     } -    actual <- withArgs [] testParser-    actual `shouldBe` expected-  it "parses the connection string double quoted" $ do-    let testArgs = ["--connectString=\"a b\""]-        expected = OConnectString "a b"+      actual <- withArgs [] testParser+      Right actual `shouldBe` expected+    it "parses the connection string double quoted" $ do+      let testArgs = ["--connectString=\"host=yahoo\""]+          expected = completeOptions $ def { host = return "yahoo" } -    actual <- withArgs testArgs testParser-    actual `shouldBe` expected-  it "parses the connection string single quoted" $ do-    let testArgs = ["--connectString='a b'"]-        expected = OConnectString "a b"+      actual <- withArgs testArgs testParser+      Right actual `shouldBe` expected+    it "parses the connection string single quoted" $ do+      let testArgs = ["--connectString='host=yahoo'"]+          expected = completeOptions $ def { host = return "yahoo" } -    actual <- withArgs testArgs testParser-    actual `shouldBe` expected-  it "parses the connection string no quotes" $ do-    let testArgs = ["--connectString=a_b"]-        expected = OConnectString "a_b"+      actual <- withArgs testArgs testParser+      Right actual `shouldBe` expected+    it "parses the connection string no quotes" $ do+      let testArgs = ["--connectString=host=yahoo"]+          expected = completeOptions $ def { host = return "yahoo" } -    actual <- withArgs testArgs testParser-    actual `shouldBe` expected-  it "fails if connectString and other args are passed" $ do-    let testArgs = ["--connectString=a_b", "--port=1234"]-        handler :: ExitCode -> Bool-        handler (ExitFailure 1) = True-        handler _ = False+      actual <- withArgs testArgs testParser+      Right actual `shouldBe` expected+    it "fails if connectString and other args are passed" $ do+      let testArgs = ["--connectString=host=yahoo", "--port=1234"]+          handler :: ExitCode -> Bool+          handler (ExitFailure 1) = True+          handler _ = False -    shouldThrow (withArgs testArgs testParser) handler+      shouldThrow (withArgs testArgs testParser) handler++  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"+          })+++