postgresql-simple-opts 0.3.0.1 → 0.4.0.0

raw patch · 4 files changed

+235/−301 lines, 4 filesdep +postgres-optionsPVP ok

version bump matches the API change (PVP)

Dependencies added: postgres-options

API changes (from Hackage documentation)

Files

• postgresql-simple-opts.cabal +4/−2
• src/Database/PostgreSQL/Simple/Options.hs +0/−298
• src/Database/PostgreSQL/Simple/PartialOptions.hs +230/−0
• test/Spec.hs +1/−1

@@ -1,5 +1,5 @@ name:                postgresql-simple-opts-version:             0.3.0.1+version:             0.4.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 Options and connection string. homepage:            https://github.com/jfischoff/postgresql-simple-opts#readme@@ -15,7 +15,7 @@  library   hs-source-dirs:      src-  exposed-modules:     Database.PostgreSQL.Simple.Options+  exposed-modules:     Database.PostgreSQL.Simple.PartialOptions   build-depends: base >= 4.6 && < 5                , postgresql-simple                , optparse-applicative@@ -26,6 +26,7 @@                , split                , uri-bytestring                , generic-deriving+               , postgres-options   default-language:    Haskell2010   ghc-options: -Wall                -fno-warn-unused-do-bind@@ -41,6 +42,7 @@                      , optparse-applicative                      , bytestring                      , data-default+                     , postgres-options   ghc-options: -Wall                -fno-warn-unused-do-bind                -threaded

@@ -1,298 +0,0 @@-{-| A resuable optparse-applicative parser for creating a postgresql-simple-   'Connection'--}-{-# 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)--- | An optional version of 'Options'. This includes an instance of--- | 'ParseRecord' which provides the optparse-applicative Parser.-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 = (<>)---- 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-  | otherwise                    = Nothing-unSingleQuote _                  = Nothing--parseString :: String -> Maybe String-parseString x = readMaybe x <|> unSingleQuote x <|> Just x--mkLast :: a -> Last a-mkLast = Last . Just---- | 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-      , 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----- | Useful for testing or if only Options are needed.-completeParser :: Parser Options-completeParser =-    fmap (either (error . unlines) id . completeOptions . mappend def) parseRecord---- | Create a connection with an 'Option'-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)-

@@ -0,0 +1,230 @@+{-| A resuable optparse-applicative parser for creating a postgresql-simple+   'Connection'+-}+{-# LANGUAGE RecordWildCards, LambdaCase, DeriveGeneric, DeriveDataTypeable #-}+{-# LANGUAGE CPP, GADTs, OverloadedStrings #-}++module Database.PostgreSQL.Simple.PartialOptions where++import Control.Monad ((<=<), foldM)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.Char (isUpper, toLower)+import Data.Default (Default(..))+import qualified Data.Either.Validation as DEV+import Data.Either.Validation (Validation(..), validationToEither)+import Data.List (intercalate)+import Data.List.Split (splitOn)+import Data.Typeable (Typeable)+import Database.PostgreSQL.Simple (ConnectInfo(..), Connection, connectPostgreSQL, defaultConnectInfo)+import Database.PostgreSQL.Simple.Options (Options(..), toConnectionString)+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (Last(..), gmappenddefault, gmemptydefault)+import Options.Applicative (Parser, (<|>), eitherReader, long, option)+import Options.Generic (Modifiers(..), ParseRecord(..), defaultModifiers, parseRecordWithModifiers)+import Text.Read (readMaybe)+import URI.ByteString as URI++-- | An optional version of 'Options'. This includes an instance of+-- | 'ParseRecord' which provides the optparse-applicative Parser.+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 = (<>)++-- 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+  | otherwise                    = Nothing+unSingleQuote _                  = Nothing++parseString :: String -> Maybe String+parseString x = readMaybe x <|> unSingleQuote x <|> Just x++mkLast :: a -> Last a+mkLast = Last . Just++-- | 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+      , dbname = mkLast $                  connectDatabase defaultConnectInfo+      }++getOption :: String -> Last a -> Validation [String] a+getOption optionName = \case+    Last (Just x) -> pure x+    Last Nothing  -> DEV.Failure ["Missing " ++ optionName ++ " option"]++getLast' :: Applicative f => Last a -> f (Maybe a)+getLast' = pure . getLast++completeOptions :: PartialOptions -> Either [String] Options+completeOptions PartialOptions {..} = validationToEither $+  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++-- | Useful for testing or if only Options are needed.+completeParser :: Parser Options+completeParser =+    fmap (either (error . unlines) id . completeOptions . mappend def) parseRecord++-- | Create a connection with an 'Option'+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')

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings, CPP #-} import Test.Hspec-import Database.PostgreSQL.Simple.Options+import Database.PostgreSQL.Simple.PartialOptions import System.Environment import Options.Applicative import System.Exit