postgresql-simple-bind 0.2.0.0 → 0.3.0.0

raw patch · 8 files changed

+161/−59 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• examples/Main.hs +7/−0
• postgresql-simple-bind.cabal +29/−5
• src/Database/PostgreSQL/Simple/Bind.hs +2/−1
• src/Database/PostgreSQL/Simple/Bind/Common.hs +14/−5
• src/Database/PostgreSQL/Simple/Bind/Implementation.hs +91/−32
• src/Database/PostgreSQL/Simple/Bind/Representation.hs +1/−1
• src/Database/PostgreSQL/Simple/Bind/Utils.hs +14/−15
• tests/Main.hs +3/−0

@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}++#ifdef DBTests import Common (withDB, withRollback) import Data.Text () import Database.PostgreSQL.Simple (Connection, ConnectInfo(..))@@ -24,3 +27,7 @@   , specUsers   , specMessages   ]+#else+main :: IO ()+main = return ()+#endif

@@ -1,6 +1,6 @@ name:                postgresql-simple-bind-version:             0.2.0.0-synopsis:            A FFI-like bindings for PostgreSQL stored functions+version:             0.3.0.0+synopsis:            FFI-like bindings for PostgreSQL stored functions description:         For tutorial see here: https:\/\/github.com\/zohl\/postgresql-simple-bind\/blob\/master\/README.md license:             BSD3 license-file:        LICENSE@@ -13,10 +13,26 @@ cabal-version:       >=1.10  flag dev-  description:        Turn on development settings.-  manual:             True-  default:            False+  description: Turn on development settings.+  manual:      True+  default:     False +flag db-tests+  description: Turn on tests with database.+  manual:      False+  default:     False++flag older-call-syntax+  description: Turn on usage of (:=) in queries instead of (=>). This+               is necessary for PostgreSQL < 9.5.+  manual:      True+  default:     True++flag debug-queries+  description: Turn on output of executed queries.+  manual:      False+  default:     False+ source-repository head   type:     git   location: https://github.com/zohl/postgresql-simple-bind.git@@ -51,7 +67,12 @@   else     ghc-options:      -O2 -Wall +  if flag(older-call-syntax)+    cpp-options: -DOlderCallSyntax +  if flag(debug-queries)+    cpp-options: -DDebugQueries+ test-suite tests   type:           exitcode-stdio-1.0 @@ -99,3 +120,6 @@     ghc-options:      -Wall -Wno-redundant-constraints -Werror   else     ghc-options:      -O2 -Wall -Wno-redundant-constraints++  if flag(db-tests)+    cpp-options: -DDBTests

@@ -19,6 +19,7 @@     bindFunction    , PostgresBindOptions(..)+  , ReturnType(..)   , PostgresBindException(..)   , PostgresType @@ -31,4 +32,4 @@  import Database.PostgreSQL.Simple.Bind.Implementation import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..), PGArgument(..), PGColumn(..), PGResult(..), PostgresBindException(..))-import Database.PostgreSQL.Simple.Bind.Common (PostgresBindOptions(..))+import Database.PostgreSQL.Simple.Bind.Common (PostgresBindOptions(..), ReturnType(..))

@@ -28,22 +28,31 @@     unwrapRow   , unwrapColumn   , PostgresBindOptions(..)+  , ReturnType(..)   ) where  import Data.Default (Default, def) import Database.PostgreSQL.Simple (Only(..)) import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..)) +-- | How to interpret results of function execution.+data ReturnType+    = AsRow+    | AsField  -- | Options that specify how to construct the function binding.-data PostgresBindOptions = PostgresBindOptions-  { pboFunctionName :: PGFunction -> String-    -- ^ Function that generates name of a binding+data PostgresBindOptions = PostgresBindOptions {+    pboFunctionName    :: PGFunction -> String     -- ^ Function that generates name of a binding.+  , pboIsNullable      :: String -> String -> Bool -- ^ Which columns in returned tables can be null.+  , pboSetOfReturnType :: String -> ReturnType     -- ^ How to process type in "setof" clause.   }  instance Default PostgresBindOptions where-  def = PostgresBindOptions-    { pboFunctionName = \(PGFunction _schema name _args _result) -> name }+  def = PostgresBindOptions {+      pboFunctionName    = \(PGFunction _schema name _args _result) -> name+    , pboIsNullable      = \_fname _column -> False+    , pboSetOfReturnType = \_tname -> AsField+    }  -- | Remove 'Only' constructor. unwrapColumn :: [Only a] -> [a]

@@ -13,6 +13,7 @@ {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE CPP                        #-}  {-|   Module:      Database.PostgreSQL.Simple.Bind.Implementation@@ -32,15 +33,21 @@   ) where  import Control.Exception (throw)++#ifdef DebugQueries+import Debug.Trace (traceId, traceShowId)+#endif+ import Data.List (intersperse) import Data.Maybe (catMaybes, maybeToList) import Data.Text (Text) import Database.PostgreSQL.Simple (Connection, query, query_) import Database.PostgreSQL.Simple.Bind.Representation (PGFunction(..), PGArgument(..), PGResult(..), PGColumn(..)) import Database.PostgreSQL.Simple.Bind.Representation (parsePGFunction, PostgresBindException(..))-import Database.PostgreSQL.Simple.Bind.Common (unwrapRow, unwrapColumn, PostgresBindOptions(..))+import Database.PostgreSQL.Simple.Bind.Common (unwrapRow, unwrapColumn, PostgresBindOptions(..), ReturnType(..)) import Database.PostgreSQL.Simple.FromField (FromField) import Database.PostgreSQL.Simple.ToField (ToField(..))+import Database.PostgreSQL.Simple.FromRow (FromRow(..)) import Database.PostgreSQL.Simple.Types (Query(..)) import GHC.TypeLits (Symbol) import Language.Haskell.TH.Syntax (Q, Dec(..), Exp(..), Type(..), Clause(..), Body(..), Pat(..))@@ -57,8 +64,17 @@ mkFunction :: PostgresBindOptions -> PGFunction -> Q [Dec] mkFunction opt f = sequence $ (($ f) . ($ opt)) <$> [mkFunctionT, mkFunctionE] +#ifdef DebugQueries+data Argument = forall a . (Show a, ToField a) => MandatoryArg String a+              | forall a . (Show a, ToField a) => OptionalArg String (Maybe a)++instance Show Argument where+  show (MandatoryArg name value) = "mandatory: " ++ name ++ " => " ++ show value+  show (OptionalArg  name value) = "optional: "  ++ name ++ " => " ++ show value+#else data Argument = forall a . (ToField a) => MandatoryArg String a               | forall a . (ToField a) => OptionalArg String (Maybe a)+#endif  instance ToField Argument where   toField (MandatoryArg _ x)         = toField x@@ -67,7 +83,13 @@  formatArgument :: Argument -> Maybe String formatArgument (MandatoryArg _name _value)      = Just "?"-formatArgument (OptionalArg name (Just _value)) = Just $ name ++ " := ?"+formatArgument (OptionalArg name (Just _value)) = Just $ name +++#ifdef OlderCallSyntax+  " := ?"+#else+  " => ?"+#endif+ formatArgument (OptionalArg _name Nothing)      = Nothing  formatArguments :: [Argument] -> String@@ -84,11 +106,12 @@ postgresT :: String -> Type postgresT t = AppT (ConT ''PostgresType) (LitT (StrTyLit t)) --- | Example: "varchar" FromField a -> [PostgresType "varchar" ~ a, FromField a]+-- | Example: ''FromField "varchar" a -> [PostgresType "varchar" ~ a, FromField a] mkContextT :: Name -> String -> Name -> [Type]-mkContextT c t n = [-    EqualityT `AppT` (postgresT t) `AppT` (VarT n)-  , (ConT c) `AppT` (VarT n)] where+mkContextT constraint typelit name = [+    EqualityT `AppT` (postgresT typelit) `AppT` (VarT name)+  , (ConT constraint) `AppT` VarT name+  ]  -- | Examples: --     (PGSingle "varchar") -> (["y"], [PostgresType "varchar" ~ y, FromField y], y)@@ -97,19 +120,30 @@ --         ["y", "z"] --       , [PostgresType "bigint" ~ y, FromField y, PostgresType "varchar" ~ z, FromField z] --       , (y, z))-mkResultT :: PGResult -> Q ([Name], [Type], Type)-mkResultT (PGSingle t) = do+mkResultT :: PostgresBindOptions -> String -> PGResult -> Q ([Name], [Type], Type)+mkResultT _ _ (PGSingle t) = do   name <- newName "y"   return ([name], mkContextT ''FromField t name, VarT name) -mkResultT (PGSetOf t) = do-  (names, context, clause) <- mkResultT (PGSingle t)-  return (names, context, AppT ListT clause)+mkResultT (PostgresBindOptions {..}) _fname (PGSetOf tname) = do+  name <- newName "y"+  let constraint = case (pboSetOfReturnType tname) of+        AsRow   -> ''FromRow+        AsField -> ''FromField+  return ([name], mkContextT constraint tname name, ListT `AppT` (VarT name)) -mkResultT (PGTable cs) = do+mkResultT (PostgresBindOptions {..}) fname (PGTable cs) = do   names <- sequence $ replicate (length cs) (newName "y")-  let context = concat $ zipWith (\(PGColumn _ t) n -> mkContextT ''FromField t n) cs names-  let clause = AppT ListT $ foldl AppT (TupleT (length cs)) $ map VarT names+  let context = concat $+        zipWith (\(PGColumn _ typelit) name -> mkContextT ''FromField typelit name) cs names++  let wrapColumn (PGColumn cname _ctype) = case pboIsNullable fname cname of+        True  -> AppT (ConT ''Maybe)+        False -> id++  let clause = AppT ListT $ foldl AppT (TupleT (length cs)) $+        zipWith wrapColumn cs (map VarT names)+   return (names, context, clause)  -- | Example: [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] -> (@@ -135,9 +169,9 @@ --           , PostgresType "bigint" ~ x2, ToField x2 --           , PostgresType "varchar" ~ x2, FromField x3) => Connection -> x1 -> Maybe x2 -> x3} mkFunctionT :: PostgresBindOptions -> PGFunction -> Q Dec-mkFunctionT (PostgresBindOptions {..}) f@(PGFunction _schema _name args ret) = do+mkFunctionT opt@(PostgresBindOptions {..}) f@(PGFunction _schema fname args ret) = do   (argNames, argContext, argClause) <- mkArgsT args-  (retNames, retContext, retClause) <- mkResultT ret+  (retNames, retContext, retClause) <- mkResultT opt fname ret    let vars = map PlainTV (argNames ++ retNames)   let context = argContext ++ retContext@@ -148,43 +182,67 @@   return $ SigD (mkName $ pboFunctionName f) $ ForallT vars context clause  +traceIdWrapE :: Exp -> Exp+#ifdef DebugQueries+traceIdWrapE q = (VarE 'traceId) `AppE` q+#else+traceIdWrapE = id+#endif+ -- | Example: --     (PGFunction "public" "foo" --       [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar")) --     args -> { Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"] }-mkSqlQuery :: PGFunction -> Maybe Name -> Exp-mkSqlQuery (PGFunction schema name _args ret) argsName = toQuery $ AppE (VarE 'concat) $ ListE [-      mkStrLit $ concat [prefix, " ", functionName, "("]+mkSqlQuery :: PostgresBindOptions -> PGFunction -> Maybe Name -> Exp+mkSqlQuery opt (PGFunction schema fname _args ret) argsName =+  toQuery . traceIdWrapE . AppE (VarE 'concat) . ListE $ [+      mkStrLit $ concat [prefix opt, " ", functionName, "("]     , maybe (mkStrLit "") (\args -> (VarE 'formatArguments) `AppE` (VarE args)) argsName     , mkStrLit ")"] where -  prefix = case ret of-    PGTable _ -> "select * from"-    _         -> "select"+  prefix (PostgresBindOptions {..}) = case ret of+    PGTable _     -> mkSelect AsRow+    PGSetOf tname -> mkSelect $ pboSetOfReturnType tname+    _             -> mkSelect AsField +  mkSelect AsRow   = "select * from"+  mkSelect AsField = "select"+   functionName = case schema of-    "" -> name-    _  -> schema ++ "." ++ name+    "" -> fname+    _  -> schema ++ "." ++ fname    mkStrLit s = LitE (StringL s)   toQuery = AppE (ConE 'Query) . AppE (VarE 'BS.pack) ++unwrapE' :: ReturnType -> Exp -> Exp+unwrapE' AsRow   q = q+unwrapE' AsField q = (VarE 'fmap) `AppE` (VarE 'unwrapColumn) `AppE` q+ -- | Examples: --     (PGSingle _) q -> { unwrapRow  q } --     (PGSetOf  _) q -> { unwrapColumn q } --     (PGTable  _) q -> { q }-unwrapE :: PGResult -> Exp -> Exp-unwrapE (PGSingle _) q = (VarE 'fmap) `AppE` (VarE 'unwrapRow) `AppE` q-unwrapE (PGSetOf _) q = (VarE 'fmap) `AppE` (VarE 'unwrapColumn) `AppE` q-unwrapE (PGTable _) q = q+unwrapE :: PostgresBindOptions -> PGResult -> Exp -> Exp+unwrapE _   (PGSingle _)    q = (VarE 'fmap) `AppE` (VarE 'unwrapRow) `AppE` q+unwrapE opt (PGSetOf tname) q = unwrapE' (pboSetOfReturnType opt tname) q+unwrapE _   (PGTable _)     q = unwrapE' AsRow q +traceShowIdWrapE :: Exp -> Exp+#ifdef DebugQueries+traceShowIdWrapE q = (VarE 'traceShowId) `AppE` q+#else+traceShowIdWrapE = id+#endif+ -- | Example: (PGFunction "public" "foo" --     [PGArgument "x" "varchar" True, PGArgument "y" "bigint" False] (PGSingle "varchar")) -> { --       foo conn x1 x2 = query conn --         (Query $ BS.pack $ concat ["select public.foo (", (formatArguments args), ")"]) --         (filterArguments [MandatoryArg "x1" x1, OptionalArg "x2" x2]) mkFunctionE :: PostgresBindOptions -> PGFunction -> Q Dec-mkFunctionE (PostgresBindOptions {..}) f@(PGFunction _schema _name args ret) = do+mkFunctionE opt@(PostgresBindOptions {..}) f@(PGFunction _schema _fname args ret) = do   names <- sequence $ replicate (length args) (newName "x")   connName <- newName "conn" @@ -200,11 +258,12 @@    let funcName = mkName $ pboFunctionName f   let funcArgs = (VarP connName):(map VarP names)-  let funcBody = NormalB $ unwrapE ret $ foldl1 AppE $ [+  let funcBody = NormalB $ unwrapE opt ret $ foldl1 AppE $ [           VarE $ maybe 'query_ (const 'query) argsName         , VarE connName-        , mkSqlQuery f argsName-        ] ++ (const argsExpr <$> maybeToList argsName)+        , mkSqlQuery opt f argsName+        ] ++ (const (traceShowIdWrapE argsExpr) <$> maybeToList argsName)    let decl = (\name -> ValD (VarP name) (NormalB argsExpr) []) <$> maybeToList argsName   return $ FunD funcName [Clause funcArgs funcBody decl]+

@@ -121,7 +121,7 @@          (map asciiCI [ "double precision" ])       ++ (map (\t -> (asciiCI t <* ss <* (modifiers $ Just 1))) ["bit", "character varying"])       ++ (map (\t -> (asciiCI t <* ss <* (modifiers $ Just 2))) ["numeric", "decimal"])-      ++ (map timeType ["timestamp", "time"])+      ++ ((asciiCI "timestamptz"):(map timeType ["timestamp", "time"]))       ++ [intervalType, identifier <* (modifiers Nothing)])      timeType t = do

@@ -34,26 +34,25 @@ import Data.List (intersperse) import Database.PostgreSQL.Simple (Connection, Only(..), query) import Database.PostgreSQL.Simple.Bind.Common (unwrapColumn)-import Database.PostgreSQL.Simple.Types (Query(..)) import Text.Heredoc (str)-import qualified Data.ByteString.Char8 as BS+import Database.PostgreSQL.Simple.SqlQQ (sql) import qualified Data.Text as T  -- | Fetch function declaration(s) from database. getFunctionDeclaration :: Connection -> String -> IO [String]-getFunctionDeclaration conn name = unwrapColumn <$> query conn sql (Only $ T.pack name) where-  sql = Query $ BS.pack $ [str|-      | select 'function '-      |     || p.proname-      |     || '('||pg_catalog.pg_get_function_arguments(p.oid)||')'-      |     || ' returns '||pg_catalog.pg_get_function_result(p.oid)-      | from pg_catalog.pg_proc p-      |      left join pg_catalog.pg_namespace n on n.oid = p.pronamespace-      | where p.proname ~ ('^('|| ? ||')$')-      |   and not p.proisagg-      |   and not p.proiswindow-      |   and p.prorettype != ('pg_catalog.trigger'::pg_catalog.regtype);-      |]+getFunctionDeclaration conn name = unwrapColumn <$> query conn sql' (Only $ T.pack name) where+  sql' = [sql|+      select 'function '+          || p.proname+          || '('||pg_catalog.pg_get_function_arguments(p.oid)||')'+          || ' returns '||pg_catalog.pg_get_function_result(p.oid)+      from pg_catalog.pg_proc p+           left join pg_catalog.pg_namespace n on n.oid = p.pronamespace+      where p.proname ~ ('^('|| ? ||')$')+        and not p.proisagg+        and not p.proiswindow+        and p.prorettype != ('pg_catalog.trigger'::pg_catalog.regtype);+    |]   -- | Generate module with bindings.

@@ -117,6 +117,9 @@       (parsePGFunction "function f(x timestamp with time zone) returns void") >>= shouldBe         (PGFunction "" "f" [PGArgument "x" "timestamp with time zone" False] (PGSingle "void")) +      (parsePGFunction "function f(x timestamptz) returns void") >>= shouldBe+        (PGFunction "" "f" [PGArgument "x" "timestamptz" False] (PGSingle "void"))+      it "works for intervals" $ do       (parsePGFunction "function f(x interval) returns void") >>= shouldBe