packages feed

servant-db-postgresql (empty) → 0.2.0.0

raw patch · 17 files changed

+1466/−0 lines, 17 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, containers, derive, hspec, monad-logger, optparse-applicative, postgresql-query, postgresql-simple, quickcheck-instances, servant, servant-db, servant-db-postgresql, text, time, transformers-base

Files

+ CHANGELOG.md view
@@ -0,0 +1,9 @@+0.2.0.0+=======++* Split `Arg` to `ArgNamed` and `ArgPos`. ++0.1.0.0+=======++* Initial release.
+ LICENSE view
@@ -0,0 +1,12 @@+Copyright (c) 2016, Anton Gushcha+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND A
+ README.md view
@@ -0,0 +1,94 @@+servant-db-postgresql+=====================++Automatic derive of [typed DB API](https://github.com/NCrashed/servant-db) based +on [postgresql-query](http://hackage.haskell.org/package/postgresql-query) package.++How to use:++* Define your instances of `MonadLogger` and `HasPostgres` for your app+monad:+``` haskell+newtype PostgresM a = PostgresM { runPostgresM :: PgMonadT (LoggingT IO) a }+  deriving (Functor, HasPostgres, MonadLogger, Monad, Applicative, MonadBase IO)+```++* Define type level API:+``` haskell+type UserId = Int++data RegisterUser = RegisterUser {+  userRegName     :: String+, userRegPassword :: String+, userRegRegTime  :: Day+} deriving (Eq)++deriveToRow ''RegisterUser++data User = User {+  userId       :: UserId+, userName     :: String+, userPassword :: String+, userRegTime  :: Day+} deriving (Eq)++deriveFromRow ''User+deriveToRow ''User++type UserAPI =+       ArgNamed "u" (Composite RegisterUser)+    :> Procedure "postUser" (Only Int)+  :<|> ArgPos Int+    :> Procedure "getUser" (Maybe User)+  :<|> ArgPos Int+    :> Procedure "deleteUser" ()+  :<|> Procedure "getUsers" [User]+```++* Derive client functions from the API:++``` haskell+postUser :: Composite RegisterUser -> PostgresM (Only Int)+getUser :: Int -> PostgresM (Maybe User)+deleteUser :: Int -> PostgresM ()+getUsers :: PostgresM [User]+(      postUser+  :<|> getUser+  :<|> deleteUser+  :<|> getUsers) = deriveDB (Proxy :: Proxy UserAPI) (Proxy :: Proxy PostgresM)+```++* Use them. The full example you can view at [example01/Main.hs](https://github.com/NCrashed/servant-db-postgresql/tree/master/example01/Main.hs) module. +And to compile it run the:+```+stack build --flag servant-db-postgresql:examples+```++Features+========++* Call functions in schema with `:>` operator:+``` haskell+type API = "test" :> ArgPos Int :> Procedure "square" (Only Int)+```+That will call function `test.square(int)`. ++* Composite types are defined with `Composite a` wrapper:+``` haskell+type API = ArgNamed "u" (Composite UserCreate) :> Procedure "postUser" (Only Int)+```++* Support for arrays:+``` haskell+type API = ArgPos (PGArray Int) :> Procedure "mleast" (Maybe (Only Int))+```++* Support for variadic arguments:+``` haskell+type API = ArgPos (Variadic Int) :> Procedure "mleast" (Maybe (Only Int))+```++* Support for default arguments with `newypte Default a = Default (Maybe a)`:+``` haskell+type API = ArgPos (Default Int) :> Procedure "foo" (Only Int)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example01/Main.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeOperators              #-}+module Main where++import           Control.Exception+import           Control.Monad             (void)+import           Control.Monad.Base+import           Control.Monad.Logger+import           Data.ByteString           (ByteString)+import           Data.Proxy+import           Data.Time+import           Database.PostgreSQL.Query+import           Servant.API.DB+import           Servant.DB.PostgreSQL++type UserId = Int++data RegisterUser = RegisterUser {+  userRegName     :: String+, userRegPassword :: String+, userRegRegTime  :: Day+} deriving (Eq)++deriveToRow ''RegisterUser++data User = User {+  userId       :: UserId+, userName     :: String+, userPassword :: String+, userRegTime  :: Day+} deriving (Eq)++deriveFromRow ''User+deriveToRow ''User++type UserAPI =+       ArgNamed "u" (Composite RegisterUser)+    :> Procedure "postUser" (Only Int)+  :<|> ArgPos Int+    :> Procedure "getUser" (Maybe User)+  :<|> ArgPos Int+    :> Procedure "deleteUser" ()+  :<|> Procedure "getUsers" [User]++newtype PostgresM a = PostgresM { runPostgresM :: PgMonadT (LoggingT IO) a }+  deriving (Functor, HasPostgres, MonadLogger, Monad, Applicative, MonadBase IO)++postUser :: Composite RegisterUser -> PostgresM (Only Int)+getUser :: Int -> PostgresM (Maybe User)+deleteUser :: Int -> PostgresM ()+getUsers :: PostgresM [User]+(      postUser+  :<|> getUser+  :<|> deleteUser+  :<|> getUsers) = deriveDB (Proxy :: Proxy UserAPI) (Proxy :: Proxy PostgresM)++main :: IO ()+main = withDB $ do+  t <- getCurrentTime+  let user = RegisterUser "Vasya" "123456" (utctDay t)+  Only i <- runDB $ postUser $ Composite user+  users <- runDB getUsers+  let user' = User {+          userId = i+        , userName = userRegName user+        , userPassword = userRegPassword user+        , userRegTime = userRegRegTime user+        }+  assertEqual "wrote != read list" [user'] users+  muser1 <- runDB $ getUser i+  assertEqual "wrote != read single" (Just user') muser1+  runDB $ deleteUser i+  muser2 <- runDB $ getUser i+  assertEqual "deleted cannot be read" Nothing muser2+  where+    assertEqual msg a b+      | a == b = return ()+      | otherwise = fail msg++dbConnection :: ByteString+dbConnection = "host=localhost dbname=servant_db_postgresql_test port=5432"++runDB :: PostgresM a -> IO a+runDB m = do+  con <- connectPostgreSQL dbConnection+  runStderrLoggingT . runPgMonadT con . runPostgresM $ m++withDB :: IO a -> IO a+withDB = bracket_ (runDB userFuncs) (runDB userFuncsDrop)++userFuncs :: PostgresM ()+userFuncs = void $ pgExecute [sqlExp|+  CREATE TYPE "userRegister" AS(+    name text,+    password text,+    regTime date+  );++  CREATE TABLE IF NOT EXISTS "users"(+    id serial PRIMARY KEY,+    name text NOT NULL,+    password text NOT NULL,+    regTime date NOT NULL+  );++  CREATE OR REPLACE FUNCTION "postUser"(u "userRegister") RETURNS integer AS $$+    INSERT INTO users(name, password, regTime) VALUES (u.name, u.password, u.regTime)+    RETURNING id;+  $$ LANGUAGE sql;++  CREATE OR REPLACE FUNCTION "getUser"(int) RETURNS users AS $$+    SELECT * FROM users WHERE id = $1;+  $$ LANGUAGE sql;++  CREATE OR REPLACE FUNCTION "deleteUser"(int) RETURNS void AS $$+    DELETE FROM users WHERE id = $1;+  $$ LANGUAGE sql;++  CREATE OR REPLACE FUNCTION "getUsers"() RETURNS SETOF users AS $$+    SELECT * FROM users;+  $$ LANGUAGE sql;+  |]++userFuncsDrop :: PostgresM ()+userFuncsDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS "postUser"(u "userCreate");+  DROP FUNCTION IF EXISTS "getUsers"();+  DROP FUNCTION IF EXISTS "getUser"(int);+  DROP FUNCTION IF EXISTS "deleteUser"(int);+  DROP TYPE IF EXISTS "userRegister" CASCADE;+  DROP TABLE IF EXISTS "users";+  |]
+ servant-db-postgresql.cabal view
@@ -0,0 +1,98 @@+name:                 servant-db-postgresql+version:              0.2.0.0+synopsis:             Derive a postgres client to database API specified by servant-db+-- description:+license:              BSD3+license-file:         LICENSE+homepage:             +author:               Anton Gushcha+maintainer:           ncrashed@gmail.com+category:             Database+copyright:            2016 (c) Anton Gushcha+build-type:           Simple+extra-source-files:+  README.md+  CHANGELOG.md+cabal-version:        >=1.10++flag examples+  description: Enables compilation of examples+  default: False++library+  exposed-modules:+    Servant.DB.PostgreSQL+    Servant.DB.PostgreSQL.Composite+    Servant.DB.PostgreSQL.Context+    Servant.DB.PostgreSQL.Default+    Servant.DB.PostgreSQL.HasDB+    Servant.DB.PostgreSQL.Variadic+  -- other-modules:+  -- other-extensions:+  build-depends:+      base                          >= 4.7   && < 5+    , bytestring                    >= 0.10  && < 0.11+    , containers                    >= 0.5   && < 0.6+    , postgresql-query              >= 3.0   && < 3.1+    , postgresql-simple             >= 0.5   && < 0.6+    , servant                       >= 0.9   && < 0.10+    , servant-db                    >= 0.2   && < 0.3+    , text                          >= 1.2   && < 1.3+  hs-source-dirs:       src+  default-language:     Haskell2010+  default-extensions:+    DeriveGeneric+    OverloadedStrings+    ScopedTypeVariables++executable servant-db-postgresql-example01+  if flag(examples)+    buildable: True+  else+    buildable: False++  main-is:              Main.hs+  hs-source-dirs:       example01+  default-language:     Haskell2010+  build-depends:+      base+    , bytestring+    , monad-logger                   >= 0.3   && < 0.4+    , postgresql-query+    , servant-db+    , servant-db-postgresql+    , time+    , transformers-base             >= 0.4   && < 0.5++test-suite servant-db-postgresql-test+  main-is:              Spec.hs+  type:                 exitcode-stdio-1.0+  other-modules:+    DB+    Fixture+    Fixture.User+    Servant.PostgreSQLSpec+  build-depends:+      base                          >= 4.7   && < 5+    , bytestring                    >= 0.10  && < 0.11+    , derive                        >= 2.5   && < 2.6+    , hspec                         >= 2.2   && < 2.4+    , HUnit                         >= 1.3   && < 1.4+    , monad-logger                  >= 0.3   && < 0.4+    , optparse-applicative          >= 0.12  && < 0.13+    , postgresql-query              >= 3.0   && < 3.1+    , QuickCheck                    >= 2.8   && < 3.0+    , quickcheck-instances          >= 0.3   && < 0.4+    , servant-db+    , servant-db-postgresql+    , text                          >= 1.2   && < 1.3+    , time                          >= 1.6   && < 1.7+    , transformers-base             >= 0.4   && < 0.5+  hs-source-dirs:       test+  default-language:     Haskell2010+  default-extensions:+    DeriveGeneric+    OverloadedStrings+    QuasiQuotes+    ScopedTypeVariables+    TemplateHaskell
+ src/Servant/DB/PostgreSQL.hs view
@@ -0,0 +1,100 @@+{-|+Module      : Servant.DB.PostgreSQL+Description : Reexport tools for deriving of PostgreSQL client for DB API.+Portability : Not portable++= Quick start++Automatic derive of [typed DB API](https://github.com/NCrashed/servant-db) based+on [postgresql-query](http://hackage.haskell.org/package/postgresql-query) package.++How to use:++* Define your instances of `MonadLogger` and `HasPostgres` for your app+monad:+@+newtype PostgresM a = PostgresM { runPostgresM :: PgMonadT (LoggingT IO) a }+  deriving (Functor, HasPostgres, MonadLogger, Monad, Applicative, MonadBase IO)+@++* Define type level API:+@+type UserId = Int++data RegisterUser = RegisterUser {+  userRegName     :: String+, userRegPassword :: String+, userRegRegTime  :: Day+} deriving (Eq)++deriveToRow ''RegisterUser++data User = User {+  userId       :: UserId+, userName     :: String+, userPassword :: String+, userRegTime  :: Day+} deriving (Eq)++deriveFromRow ''User+deriveToRow ''User++type UserAPI =+       ArgNamed "u" (Composite RegisterUser)+    :> Procedure "postUser" (Only Int)+  :<|> ArgPos Int+    :> Procedure "getUser" (Maybe User)+  :<|> ArgPos Int+    :> Procedure "deleteUser" ()+  :<|> Procedure "getUsers" [User]+@++* Derive client functions from the API:++@+postUser :: Composite RegisterUser -> PostgresM (Only Int)+getUser :: Int -> PostgresM (Maybe User)+deleteUser :: Int -> PostgresM ()+getUsers :: PostgresM [User]+(      postUser+  :<|> getUser+  :<|> deleteUser+  :<|> getUsers) = deriveDB (Proxy :: Proxy UserAPI) (Proxy :: Proxy PostgresM)+@++= Features++* Call functions in schema with `:>` operator:+@+type API = "test" :> ArgPos Int :> Procedure "square" (Only Int)+@+That will call function `test.square(int)`.++* Composite types are defined with `Composite a` wrapper:+@+type API = ArgNamed "u" (Composite UserCreate) :> Procedure "postUser" (Only Int)+@++* Support for arrays:+@+type API = ArgPos (PGArray Int) :> Procedure "mleast" (Maybe (Only Int))+@++* Support for variadic arguments:+@+type API = ArgPos (Variadic Int) :> Procedure "mleast" (Maybe (Only Int))+@++* Support for default arguments with `Default` wrapper:+@+type API = ArgPos (Default Int) :> Procedure "foo" (Only Int)+@++-}+module Servant.DB.PostgreSQL(+    module Reexport+  ) where++import           Servant.DB.PostgreSQL.Composite as Reexport+import           Servant.DB.PostgreSQL.HasDB     as Reexport+import           Servant.DB.PostgreSQL.Variadic  as Reexport
+ src/Servant/DB/PostgreSQL/Composite.hs view
@@ -0,0 +1,28 @@+{-|+Module      : Servant.DB.PostgreSQL.Composite+Description : Composite types support.+Portability : Not portable+-}+module Servant.DB.PostgreSQL.Composite(+    Composite(..)+  ) where++import           Data.List                          (intersperse)+import           Data.Typeable+import           Database.PostgreSQL.Simple.ToField+import           Database.PostgreSQL.Simple.ToRow+import           GHC.Generics++-- | Wrapper around 'a' that indicates that the type can be used as composite+-- type.+--+-- >>> type UserAPI = Arg "u" (Composite User) :> Procedure "insertUser" ()+newtype Composite a = Composite { unComposite :: a }+  deriving (Typeable, Eq, Generic, Show, Read, Ord)++instance ToRow a => ToField (Composite a) where+  toField (Composite a) = Many [+      Plain "("+    , Many $ intersperse (Plain ",") $ toRow a+    , Plain ")"+    ]
+ src/Servant/DB/PostgreSQL/Context.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE TypeFamilies              #-}+{-|+Module      : Servant.DB.PostgreSQL.Context+Description : Query context that is used as temp storage+Portability : Not portable+-}+module Servant.DB.PostgreSQL.Context(+    Argument(..)+  , QueryArg(..)+  , QueryContext(..)+  , newQueryContext+  , addQueryArgument+  , queryStoredFunction+  ) where++import           Data.Foldable+import           Data.Kind+import           Data.List                        (intersperse)+import           Data.Monoid+import           Data.Sequence                    (Seq)+import qualified Data.Sequence                    as S+import           Data.Text                        (Text)+import           Database.PostgreSQL.Query+import           Database.PostgreSQL.Simple.Types hiding (Default)+import           GHC.Generics+import           Servant.DB.PostgreSQL.Variadic++-- | Captures special cases of stored function arguments+data Argument a =+    ArgVariadic (Variadic a) -- ^ Variadic argument has uncommon call syntax+  | ArgDefault (Maybe a) -- ^ Default keyword+  | ArgSimple a -- ^ Common case+  deriving (Generic, Eq, Show)++-- | Encapsulated argument that can be serialized into field or type checked+--+-- The type parameter can be 'ToField' for query generation or 'Typeable' for+-- type checking of DB signature.+data QueryArg (r :: * -> Constraint) = forall a . r a => QueryArg (Argument a)++-- | Check whether an argument is not specified+isDefaultArg :: QueryArg r -> Bool+isDefaultArg (QueryArg (ArgDefault Nothing)) = True+isDefaultArg _                               = False++-- | Catches intermediate parameters for query+data QueryContext (r :: * -> Constraint) = QueryContext {+  -- | List of named and positional arguments+  queryArguments :: !(Seq (Maybe Text, QueryArg r))+  -- | Schema name+, querySchema    :: !(Maybe Text)+  -- | Whether the query returns void+, queryVoid      :: !Bool+}++-- | New empty query context+newQueryContext :: QueryContext r+newQueryContext = QueryContext {+    queryArguments = mempty+  , querySchema = Nothing+  , queryVoid = False+  }++-- | Add new argument to query context+addQueryArgument :: r a+  => Maybe Text -- ^ Name of argument, 'Nothing' for positional arguments+  -> Argument a -- ^ Value of argument+  -> QueryContext r -- ^ Context+  -> QueryContext r -- ^ New context with the argument+addQueryArgument name a ctx = ctx {+    queryArguments = queryArguments ctx S.|> (name, QueryArg a)+  }++-- | Helper to split positional and named arguments+--+-- PG call conventions require that named arguments cannot+-- precede positional ones.+querySplitArguments :: QueryContext r+  -> (Seq (QueryArg r), Seq (Text, QueryArg r))+querySplitArguments QueryContext{..} = foldl' go (mempty, mempty) queryArguments+  where+    go :: (Seq (QueryArg r), Seq (Text, QueryArg r)) -> (Maybe Text, QueryArg r)+      -> (Seq (QueryArg r), Seq (Text, QueryArg r))+    go (!posed, !named) (mn, a) = case mn of+      Nothing -> (posed S.|> a, named)+      Just n  -> (posed, named S.|> (n, a))++-- | Construct query that calls DB stored function+queryStoredFunction+  :: forall r . r ~ ToField+  => Text -- ^ Name of function+  -> QueryContext r -- ^ Context+  -> SqlBuilder+queryStoredFunction name ctx =+     "SELECT "+  <> (if queryVoid ctx then mempty else "* FROM ")+  <> toSqlBuilder (QualifiedIdentifier (querySchema ctx) name)+  <> "("+  <> (if S.null posed then mempty+      else posedBuilder <> (if S.null named then mempty else ", "))+  <> (if S.null named then mempty else namedBuilder)+  <> ")"+  <> (if queryVoid ctx then ";" else " as t;")+  where+    (posed', named') = querySplitArguments ctx+    posed = S.filter (not . isDefaultArg) posed'+    named = S.filter (not . isDefaultArg . snd) named'+    posedBuilder =  mconcat (addCommas $ argPosedBuilder <$> toList posed)+    namedBuilder = mconcat (addCommas $ uncurry argNamedBuilder <$> toList named)++    addCommas = intersperse ", "+    argPosedBuilder :: QueryArg r -> SqlBuilder+    argPosedBuilder (QueryArg marg) = case marg of+      ArgVariadic (Variadic va) -> "VARIADIC " <> mkValue va+      ArgDefault da -> case da of+        Nothing -> "" -- already handled+        Just a  -> mkValue a+      ArgSimple a -> mkValue a++    argNamedBuilder :: Text -> QueryArg r -> SqlBuilder+    argNamedBuilder aname (QueryArg marg) = case marg of+      ArgVariadic (Variadic a) -> "VARIADIC " <> toSqlBuilder (Identifier aname) <> " => " <> mkValue a+      ArgDefault da -> case da of+        Nothing -> "" -- already handled+        Just a  -> toSqlBuilder (Identifier aname) <> " => " <> mkValue a+      ArgSimple a -> toSqlBuilder (Identifier aname) <> " => " <> mkValue a
+ src/Servant/DB/PostgreSQL/Default.hs view
@@ -0,0 +1,15 @@+{-|+  Module      : Servant.DB.PostgreSQL.Default+  Description : Newtype wrapper for marking an default argument+  Portability : Portable+-}+module Servant.DB.PostgreSQL.Default(+    Default(..)+  ) where++import           Data.Typeable+import           GHC.Generics++-- | Wrapper around 'Maybe' to distinguish default arguments from nullable ones+newtype Default a = Default { unDefault :: Maybe a }+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+ src/Servant/DB/PostgreSQL/HasDB.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# OPTIONS_GHC -fno-warn-orphans      #-}+{-|+Module      : Servant.DB.PostgreSQL.HasDB+Description : Deriving DB client from API+Portability : Not portable+-}+module Servant.DB.PostgreSQL.HasDB(+    deriveDB+  , HasDB(..)+  , module Reexport+  ) where++import           Control.Applicative+import           Control.Monad                      (replicateM_)+import           Data.Monoid+import           Data.Proxy+import           Data.Text                          (pack)+import           Database.PostgreSQL.Query+import           Database.PostgreSQL.Simple.FromRow+import           Database.PostgreSQL.Simple.Types   (Null)+import           GHC.TypeLits+import           Servant.API+import           Servant.API.DB+import           Servant.DB.PostgreSQL.Context+import           Servant.DB.PostgreSQL.Default+import           Servant.DB.PostgreSQL.Variadic++import           Database.PostgreSQL.Simple         as Reexport (Only (..))++-- | Derive DB client from API+deriveDB :: HasDB layout m+  => Proxy layout -- ^ API layout+  -> Proxy m -- ^ PostgreSQL monad we operate in+  -> DB layout m -- ^ Derived functions+deriveDB layout m = deriveDBWithCtx layout m newQueryContext++-- | Derive DB client from API+class HasDB layout (m :: * -> *) where+  -- | Associated type of deriving result+  type DB layout m :: *++  -- | Derive DB client from API layout+  deriveDBWithCtx :: Proxy layout -> Proxy m -> QueryContext ToField+    -> DB layout m++-- | Deriving several procedures to query DB API+--+-- @+-- type API = Procedure "time" Integer+--   :<|> ArgNamed "a" Int :> Procedure "square" (Only Int)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- time :: MyMonad (Only Integer)+-- square :: Int -> MyMonad (Only Int)+-- (time, square) = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive separate endpoints with the following SQL calls:+-- >>> SELECT time();+-- >>> SELECT square("a" => ?);+instance (HasDB api1 m, HasDB api2 m) => HasDB (api1 :<|> api2) m where+  type DB (api1 :<|> api2) m = DB api1 m :<|> DB api2 m++  deriveDBWithCtx _ m ctx =+         deriveDBWithCtx (Proxy :: Proxy api1) m ctx+    :<|> deriveDBWithCtx (Proxy :: Proxy api2) m ctx+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving several procedures to query DB API+--+-- @+-- type API = "public" :> Procedure "time" (Only Integer)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- time :: MyMonad (Only Integer)+-- time = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- The `time` function will call DB with the:+-- >>> SELECT public.time();+--+-- Note that there could be only one schema marker. If there are more than one+-- the later (righter) will override previous ones.+instance (KnownSymbol n, HasDB api m) => HasDB (n :> api) m where+  type DB (n :> api) m = DB api m++  deriveDBWithCtx _ m ctx = deriveDBWithCtx (Proxy :: Proxy api) m ctx'+    where+      n = pack $ symbolVal (Proxy :: Proxy n)+      ctx' = ctx { querySchema = Just n }+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with named arguments+--+-- @+-- type API = ArgNamed "a" Int :> ArgNamed "b" Int :> Procedure "sum" (Only Int)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- dbSum :: Int -> Int -> MyMonad (Only Int)+-- dbSum = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM sum("a" => ?, "b" => ?) AS t;+instance {-# OVERLAPPABLE #-} (KnownSymbol n, ToField a, HasDB api m) => HasDB (ArgNamed n a :> api) m where+  type DB (ArgNamed n a :> api) m = a -> DB api m++  deriveDBWithCtx _ m ctx a = deriveDBWithCtx (Proxy :: Proxy api) m ctx'+    where+      n = pack $ symbolVal (Proxy :: Proxy n)+      ctx' = addQueryArgument (Just n) (ArgSimple a) ctx+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with named variadic arguments+--+-- @+-- type API = ArgNamed "arr" (Variadic Int) :> Procedure "mleast" (Only Int)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- dbMleast :: Variadic Int -> MyMonad (Only Int)+-- dbMleast = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM mleast(VARIADIC "arr" => ?) AS t;+instance {-# OVERLAPPING #-} (KnownSymbol n, ToField a, HasDB api m) => HasDB (ArgNamed n (Variadic a) :> api) m where+  type DB (ArgNamed n (Variadic a) :> api) m = Variadic a -> DB api m++  deriveDBWithCtx _ m ctx a = deriveDBWithCtx (Proxy :: Proxy api) m ctx'+    where+      n = pack $ symbolVal (Proxy :: Proxy n)+      ctx' = addQueryArgument (Just n) (ArgVariadic a) ctx+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with named default arguments+--+-- @+-- type API = ArgNamed "a" (Defaultable Int) :> Procedure "foo" (Only Int)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- dbFoo :: Defaultable Int -> MyMonad (Only Int)+-- dbFoo = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM default(DEFAULT) AS t;+instance {-# OVERLAPPING #-} (KnownSymbol n, ToField a, HasDB api m) => HasDB (ArgNamed n (Default a) :> api) m where+  type DB (ArgNamed n (Default a) :> api) m = Default a -> DB api m++  deriveDBWithCtx _ m ctx a = deriveDBWithCtx (Proxy :: Proxy api) m ctx'+    where+      n = pack $ symbolVal (Proxy :: Proxy n)+      ctx' = addQueryArgument (Just n) (ArgDefault $ unDefault a) ctx+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with positional arguments+--+-- @+-- type API = Arg Int :> Arg Int :> Procedure "sum" (Only Int)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- dbSum :: Int -> Int -> MyMonad (Only Int)+-- dbSum = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM sum(?, ?) AS t;+instance {-# OVERLAPPABLE #-} (ToField a, HasDB api m) => HasDB (ArgPos a :> api) m where+  type DB (ArgPos a :> api) m = a -> DB api m++  deriveDBWithCtx _ m ctx a = deriveDBWithCtx (Proxy :: Proxy api) m ctx'+    where+      ctx' = addQueryArgument Nothing (ArgSimple a) ctx+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with positional variadic arguments+--+-- @+-- type API = ArgPos (Variadic Int) :> Procedure "mleast" (Only Int)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- dbMleast :: Variadic Int -> MyMonad (Only Int)+-- dbMleast = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM mleast(VARIADIC ?) AS t;+instance {-# OVERLAPPING #-} (ToField a, HasDB api m) => HasDB (ArgPos (Variadic a) :> api) m where+  type DB (ArgPos (Variadic a) :> api) m = Variadic a -> DB api m++  deriveDBWithCtx _ m ctx a = deriveDBWithCtx (Proxy :: Proxy api) m ctx'+    where+      ctx' = addQueryArgument Nothing (ArgVariadic a) ctx+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with positional default arguments+--+-- @+-- type API = ArgPos (Default Int) :> Procedure "foo" (Only Int)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- dbFoo :: Default Int -> MyMonad (Only Int)+-- dbFoo = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM foo(DEFAULT) AS t;+instance {-# OVERLAPPING #-} (ToField a, HasDB api m) => HasDB (ArgPos (Default a) :> api) m where+  type DB (ArgPos (Default a) :> api) m = Default a -> DB api m++  deriveDBWithCtx _ m ctx a = deriveDBWithCtx (Proxy :: Proxy api) m ctx'+    where+      ctx' = addQueryArgument Nothing (ArgDefault $ unDefault a) ctx+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with no return type+--+-- @+-- data User -- user data+-- instance ToRow User+--+-- type API = Arg "user" User :> Procedure "registerUser" ()+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- getUsers :: User -> MyMonad ()+-- getUsers = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT registerUser("user" => ?);+--+-- And the instance expects that `users` function return type is `SETOF user`.+instance {-# OVERLAPPING #-} (KnownSymbol n, MonadPostgres m)+  => HasDB (Procedure n ()) m where+  type DB (Procedure n ()) m = m ()++  deriveDBWithCtx _ _ ctx = do+    (_ :: [Only ()]) <- pgQuery q+    return ()+    where+      n = pack $ symbolVal (Proxy :: Proxy n)+      q = queryStoredFunction n ctx { queryVoid = True }+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with multiple result+--+-- @+-- data User -- user data+-- instance FromRow User+--+-- type API = Procedure "users" [User]+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- getUsers :: MyMonad [User]+-- getUsers = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM users() AS t;+--+-- And the instance expects that `users` function return type is `SETOF user`.+instance {-# OVERLAPPING #-} (KnownSymbol n, FromRow a, MonadPostgres m)+  => HasDB (Procedure n [a]) m where+  type DB (Procedure n [a]) m = m [a]++  deriveDBWithCtx _ _ ctx = pgQuery q+    where+      n = pack $ symbolVal (Proxy :: Proxy n)+      q = queryStoredFunction n ctx+  {-# INLINE deriveDBWithCtx #-}++nullRow :: RowParser Null+nullRow = field++instance FromRow a => FromRow (Maybe a) where+  fromRow = do+    n <- numFieldsRemaining+    (replicateM_ n nullRow *> pure Nothing) <|> (Just <$> fromRow)++-- | Deriving call to DB procedure with optional result+--+-- @+-- data User -- user data+-- instance FromRow User+--+-- type API = ArgPos Int :> Procedure "user" (Maybe User)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- getUsers :: MyMonad (Maybe User)+-- getUsers = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM user(?) AS t;+instance {-# OVERLAPPING #-} (KnownSymbol n, FromRow a, MonadPostgres m)+  => HasDB (Procedure n (Maybe a)) m where+  type DB (Procedure n (Maybe a)) m = m (Maybe a)++  deriveDBWithCtx _ _ ctx = do+    res <- pgQuery q+    case res of+      x : _ -> return x+      _     -> return Nothing+    where+      n = pack $ symbolVal (Proxy :: Proxy n)+      q = queryStoredFunction n ctx+  {-# INLINE deriveDBWithCtx #-}++-- | Deriving call to DB procedure with single result+--+-- @+-- type API = Arg "a" Int -> Procedure "squareReturning" (Int, Int)+--+-- data MyMonad m a -- Your application monad with connection pool and logger+-- instance HasPostgres m+-- instance MonadLogger m+--+-- square :: Int -> MyMonad (Int, Int)+-- square = deriveDB (Proxy :: Proxy API) (Proxy :: Proxy MyMonad)+-- @+--+-- Upper example will derive the following SQL call:+-- >>> SELECT * FROM squareReturning() AS t;+--+-- The instance expects that return type of SQL stored function is a single row.+instance {-# OVERLAPPABLE #-} (KnownSymbol n, FromRow a, MonadPostgres m)+  => HasDB (Procedure n a) m where+  type DB (Procedure n a) m = m a++  deriveDBWithCtx _ _ ctx = do+    mv <- pgQuery q+    case mv of+      [] -> fail $ "deriveDBWithCtx: received zero results when expected"+        <> " exactly one. PG Function: " <> n'+      (v : _) -> return v+    where+      n' = symbolVal (Proxy :: Proxy n){--}+      n = pack n'+      q = queryStoredFunction n ctx+  {-# INLINE deriveDBWithCtx #-}
+ src/Servant/DB/PostgreSQL/Variadic.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Servant.DB.PostgreSQL.Variadic(+    Variadic(..)+  , PGArray(..)+  ) where++import           Database.PostgreSQL.Simple.Types++newtype Variadic a = Variadic { unVariadic :: PGArray a }+  deriving (Functor, Eq, Ord, Read, Show)
+ test/DB.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module DB(+    PostgresM+  , runDB+  ) where++import           Control.Monad.Base+import           Control.Monad.Logger+import           Data.ByteString           (ByteString)+import qualified Data.ByteString.Char8     as BS+import           Data.Maybe+import           Database.PostgreSQL.Query+import           Options.Applicative++newtype PostgresM a = PostgresM { runPostgresM :: PgMonadT (LoggingT IO) a }+  deriving (Functor, HasPostgres, MonadLogger, Monad, Applicative, MonadBase IO)++dbConnection :: ByteString+dbConnection = "host=localhost dbname=servant_db_postgresql_test port=5432"++cliConnection :: IO (Maybe ByteString)+cliConnection = execParser opts+  where+    opts = info (helper <*> cliParser)+       (  fullDesc+       <> progDesc "Test suite for servant-db-postgresql package"+       <> header "Runs integration tests for servant-db-postgresql package" )++cliParser :: Parser (Maybe ByteString)+cliParser = optional $ BS.pack+  <$> strOption (+       long "connection"+    <> help "Custom connection string to PostgreSQL"+    )++ -- | Run tests with DB connection+runDB :: PostgresM a -> IO a+runDB m = do+  mconf <- cliConnection+  let conf = fromMaybe dbConnection mconf+  con <- connectPostgreSQL conf+  runStderrLoggingT . runPgMonadT con . runPostgresM $ m
+ test/Fixture.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE QuasiQuotes   #-}+{-# LANGUAGE TypeOperators #-}+module Fixture(+    SquareAPI+  , SquareSchemaAPI+  , SuccAndPredAPI+  , UserAPI+  , OrderedAPI1+  , OrderedAPI2+  , VoidAPI+  , VariadicAPI+  , ArrayAPI+  , DefaultAPI+  , withSquareFunc+  , withTestSchema+  , withSquareSchema+  , withSuccAndPred+  , withUserFuncs+  , withOrderedFuncs+  , withVoid+  , withVariadic+  , withArrayFuncs+  , withDefaultFuncs+  , module Reexport+  ) where++import           Control.Exception+import           Control.Monad+import           Database.PostgreSQL.Query+import           DB+import           Servant.API.DB+import           Servant.DB.PostgreSQL+import           Servant.DB.PostgreSQL.Default++import           Fixture.User                  as Reexport++type SquareAPI = ArgNamed "a" Int :> Procedure "square1" (Only Int)+type SquareSchemaAPI = "test" :> ArgNamed "b" Int :> Procedure "square2" (Only Int)+type SuccAndPredAPI = ArgNamed "n" Int :> Procedure "succAndPred" (Int, Int)+type UserAPI =+       ArgNamed "u" (Composite UserCreate) :> Procedure "postUser" (Only Int)+  :<|> ArgPos Int :> Procedure "getUser" (Maybe User)+  :<|> ArgPos Int :> Procedure "deleteUser" ()+  :<|> Procedure "getUsers" [User]+type OrderedAPI1 = ArgPos Int :> ArgPos Int :> ArgNamed "a" Int+  :> Procedure "ordered" (Only Int)+type OrderedAPI2 = ArgPos Int :> ArgNamed "a" Int :> ArgPos Int+  :> Procedure "ordered" (Only Int)+type VoidAPI = Procedure "void" ()+type VariadicAPI = ArgNamed "arr" (Variadic Int) :> Procedure "mleast" (Maybe (Only Int))+type ArrayAPI = ArgPos (PGArray Int) :> Procedure "mleast" (Maybe (Only Int))+type DefaultAPI = ArgNamed "a" (Default Int) :> ArgPos (Default Int) :> Procedure "foo" (Only Int)++-- | Helper to make cleanable migration+withMigration :: PostgresM () -> PostgresM () -> IO c -> IO c+withMigration before after = bracket_ (runDB before) (runDB after)++withSquareFunc :: IO a -> IO a+withSquareFunc = withMigration squareFunction squareFunctionDrop++-- | Stored function for squaring input+squareFunction :: PostgresM ()+squareFunction = void $ pgExecute [sqlExp|+  CREATE OR REPLACE FUNCTION square1(a integer) RETURNS integer AS $$+  BEGIN+    RETURN a*a;+  END;+  $$ LANGUAGE plpgsql;+  |]++-- | Delete square function+squareFunctionDrop :: PostgresM ()+squareFunctionDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS square1(a integer);+  |]++withTestSchema :: IO a -> IO a+withTestSchema = withMigration testSchema testSchemaDrop++-- | Create test schema+testSchema :: PostgresM ()+testSchema = void $ pgExecute [sqlExp|CREATE SCHEMA IF NOT EXISTS test;|]++-- | Delete test schema+testSchemaDrop :: PostgresM ()+testSchemaDrop = void $ pgExecute [sqlExp|DROP SCHEMA test;|]++withSquareSchema :: IO a -> IO a+withSquareSchema = withMigration squareFunctionSchema squareFunctionSchemaDrop++-- | Stored function for squaring input+squareFunctionSchema :: PostgresM ()+squareFunctionSchema = void $ pgExecute [sqlExp|+  CREATE OR REPLACE FUNCTION test.square2(b integer) RETURNS integer AS $$+  BEGIN+    RETURN b*b;+  END;+  $$ LANGUAGE plpgsql;+  |]++-- | Delete square function+squareFunctionSchemaDrop :: PostgresM ()+squareFunctionSchemaDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS test.square2(b integer);+  |]++withSuccAndPred :: IO a -> IO a+withSuccAndPred = withMigration succAndPredFunc succAndPredFuncDrop++succAndPredFunc :: PostgresM ()+succAndPredFunc = void $ pgExecute [sqlExp|+  CREATE OR REPLACE FUNCTION "succAndPred"(n integer) RETURNS TABLE (a integer, b integer) AS $$+    SELECT n+1 as a, n-1 as b;+  $$ LANGUAGE sql;+  |]++succAndPredFuncDrop :: PostgresM ()+succAndPredFuncDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS "succAndPred"(n integer);+  |]++withUserFuncs :: IO a -> IO a+withUserFuncs = withMigration userFuncs userFuncsDrop++userFuncs :: PostgresM ()+userFuncs = void $ pgExecute [sqlExp|+  CREATE TYPE "userCreate" AS(+    name text,+    password text,+    regTime date+  );++  CREATE TABLE IF NOT EXISTS "users"(+    id serial PRIMARY KEY,+    name text NOT NULL,+    password text NOT NULL,+    regTime date NOT NULL+  );++  CREATE OR REPLACE FUNCTION "postUser"(u "userCreate") RETURNS integer AS $$+    INSERT INTO users(name, password, regTime) VALUES (u.name, u.password, u.regTime)+    RETURNING id;+  $$ LANGUAGE sql;++  CREATE OR REPLACE FUNCTION "getUser"(int) RETURNS users AS $$+    SELECT * FROM users WHERE id = $1;+  $$ LANGUAGE sql;++  CREATE OR REPLACE FUNCTION "deleteUser"(int) RETURNS void AS $$+    DELETE FROM users WHERE id = $1;+  $$ LANGUAGE sql;++  CREATE OR REPLACE FUNCTION "getUsers"() RETURNS SETOF users AS $$+    SELECT * FROM users;+  $$ LANGUAGE sql;+  |]++userFuncsDrop :: PostgresM ()+userFuncsDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS "postUser"(u "userCreate");+  DROP FUNCTION IF EXISTS "getUsers"();+  DROP FUNCTION IF EXISTS "getUser"(int);+  DROP FUNCTION IF EXISTS "deleteUser"(int);+  DROP TYPE IF EXISTS "userCreate" CASCADE;+  DROP TABLE IF EXISTS "users";+  |]++withOrderedFuncs :: IO a -> IO a+withOrderedFuncs = withMigration orderedFuncs orderedFuncsDrop++orderedFuncs :: PostgresM ()+orderedFuncs = void $ pgExecute [sqlExp|+  CREATE OR REPLACE FUNCTION "ordered"(integer, integer, a integer) RETURNS integer AS $$+  BEGIN+    RETURN $1 + $2*2 + a*3;+  END;+  $$ LANGUAGE plpgsql;+  |]++orderedFuncsDrop :: PostgresM ()+orderedFuncsDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS "ordered"(integer, integer, a integer);+ |]++withVoid :: IO a -> IO a+withVoid = withMigration voidFunc voidFuncDrop++voidFunc :: PostgresM ()+voidFunc = void $ pgExecute [sqlExp|+  CREATE OR REPLACE FUNCTION "void"() RETURNS void AS $$+  BEGIN+  END;+  $$ LANGUAGE plpgsql;+  |]++voidFuncDrop :: PostgresM ()+voidFuncDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS "void"();+  |]++withVariadic :: IO a -> IO a+withVariadic = withMigration variadicFunc variadicFuncDrop++variadicFunc :: PostgresM ()+variadicFunc = void $ pgExecute [sqlExp|+  CREATE OR REPLACE FUNCTION "mleast"(VARIADIC arr int[]) RETURNS int AS $$+      SELECT min($1[i]) FROM generate_subscripts($1, 1) g(i);+  $$ LANGUAGE SQL;+  |]++variadicFuncDrop :: PostgresM ()+variadicFuncDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS "mleast"(VARIADIC arr int[]);+  |]++withArrayFuncs :: IO a -> IO a+withArrayFuncs = withMigration arrayFuncs arrayFuncsDrop++arrayFuncs :: PostgresM ()+arrayFuncs = void $ pgExecute [sqlExp|+  CREATE OR REPLACE FUNCTION "mleast"(int[]) RETURNS int AS $$+      SELECT min($1[i]) FROM generate_subscripts($1, 1) g(i);+  $$ LANGUAGE SQL;+  |]++arrayFuncsDrop :: PostgresM ()+arrayFuncsDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS "mleast"(int[]);+  |]++withDefaultFuncs :: IO a -> IO a+withDefaultFuncs = withMigration defaultFuncs defaultFuncsDrop++defaultFuncs :: PostgresM ()+defaultFuncs = void $ pgExecute [sqlExp|+  CREATE OR REPLACE FUNCTION "foo"(int default 0, "a" int default 0) RETURNS int AS $$+  BEGIN+    RETURN $1+a;+  END;+  $$ LANGUAGE plpgsql;+  |]++defaultFuncsDrop :: PostgresM ()+defaultFuncsDrop = void $ pgExecute [sqlExp|+  DROP FUNCTION IF EXISTS "foo"(int, "a" int);+  |]
+ test/Fixture/User.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TemplateHaskell            #-}+module Fixture.User(+    User(..)+  , UserCreate(..)+  , userToUserCreate+  , userCreateToUser+  ) where++import           Data.DeriveTH+import           Data.Time+import           Database.PostgreSQL.Query+import           GHC.Generics+import           Test.QuickCheck.Arbitrary+import           Test.QuickCheck.Instances++newtype NotNullString = NotNullString String+  deriving (Eq, Show, FromField, ToField)++instance Arbitrary NotNullString where+  arbitrary = NotNullString . filter (/= '\0') <$> arbitrary++-- | Sample User record that is used to test custom types as return type+data User = User {+  userId       :: !Int+, userName     :: !NotNullString+, userPassword :: !NotNullString+, userRegDay   :: !Day+} deriving (Generic, Eq, Show)++derive makeArbitrary ''User+deriveFromRow ''User+deriveToRow ''User++-- | Sample User record that is used to test custom types as return type+data UserCreate = UserCreate {+  userCreateName     :: !NotNullString+, userCreatePassword :: !NotNullString+, userCreateRegDay   :: !Day+} deriving (Generic, Eq, Show)++derive makeArbitrary ''UserCreate+deriveFromRow ''UserCreate+deriveToRow ''UserCreate++userToUserCreate :: User -> UserCreate+userToUserCreate User{..} = UserCreate {+    userCreateName = userName+  , userCreatePassword = userPassword+  , userCreateRegDay = userRegDay+  }++userCreateToUser :: UserCreate -> Int -> User+userCreateToUser UserCreate{..} i = User {+    userId = i+  , userName = userCreateName+  , userPassword = userCreatePassword+  , userRegDay = userCreateRegDay+  }
+ test/Servant/PostgreSQLSpec.hs view
@@ -0,0 +1,99 @@+module Servant.PostgreSQLSpec(spec) where++import           Data.Proxy+import           DB+import           Fixture+import           Test.Hspec                    hiding (Arg)+import           Test.HUnit+import           Test.QuickCheck++import           Servant.API.DB+import           Servant.DB.PostgreSQL+import           Servant.DB.PostgreSQL.Default++square :: Int -> PostgresM (Only Int)+square = deriveDB (Proxy :: Proxy SquareAPI) (Proxy :: Proxy PostgresM)++squareSchema :: Int -> PostgresM (Only Int)+squareSchema = deriveDB (Proxy :: Proxy SquareSchemaAPI) (Proxy :: Proxy PostgresM)++succAndPred :: Int -> PostgresM (Int, Int)+succAndPred = deriveDB (Proxy :: Proxy SuccAndPredAPI) (Proxy :: Proxy PostgresM)++postUser :: Composite UserCreate -> PostgresM (Only Int)+getUser :: Int -> PostgresM (Maybe User)+deleteUser :: Int -> PostgresM ()+getUsers :: PostgresM [User]+(      postUser+  :<|> getUser+  :<|> deleteUser+  :<|> getUsers) = deriveDB (Proxy :: Proxy UserAPI) (Proxy :: Proxy PostgresM)++ordered1 :: Int -> Int -> Int -> PostgresM (Only Int)+ordered1 = deriveDB (Proxy :: Proxy OrderedAPI1) (Proxy :: Proxy PostgresM)++ordered2 :: Int -> Int -> Int -> PostgresM (Only Int)+ordered2 = deriveDB (Proxy :: Proxy OrderedAPI2) (Proxy :: Proxy PostgresM)++voidProc :: PostgresM ()+voidProc = deriveDB (Proxy :: Proxy VoidAPI) (Proxy :: Proxy PostgresM)++variadicProc :: Variadic Int -> PostgresM (Maybe (Only Int))+variadicProc = deriveDB (Proxy :: Proxy VariadicAPI) (Proxy :: Proxy PostgresM)++arrayProc :: PGArray Int -> PostgresM (Maybe (Only Int))+arrayProc = deriveDB (Proxy :: Proxy ArrayAPI) (Proxy :: Proxy PostgresM)++defaultProc :: Default Int -> Default Int -> PostgresM (Only Int)+defaultProc = deriveDB (Proxy :: Proxy DefaultAPI) (Proxy :: Proxy PostgresM)++spec :: Spec+spec = describe "Servant.DB.PostgreSQL" $ do+  it "can call simple stored functions" $ withSquareFunc $ do+    Only b <- runDB $ square 4+    assertEqual "4^2 = 16" 16 b+  it "can call stored functions in schema" $ withTestSchema $ withSquareSchema $ do+    Only b <- runDB $ squareSchema 4+    assertEqual "4^2 = 16" 16 b+  it "supports row return" $ withSuccAndPred $ do+    b <- runDB $ succAndPred 4+    assertEqual "4+1 and 4-1 = (5, 3)" (5,3) b+  it "supports table return" $ withUserFuncs $ do+    user <- generate arbitrary+    Only i <- runDB $ postUser $ Composite user+    users <- runDB getUsers+    let user' = userCreateToUser user i+    assertEqual "wrote == read list" [user'] users+    muser1 <- runDB $ getUser i+    assertEqual "wrote == read single" (Just user') muser1+    runDB $ deleteUser i+    muser2 <- runDB $ getUser i+    assertEqual "deleted cannot be read" Nothing muser2+  it "handles ordered arguments" $ withOrderedFuncs $ do+    Only b <- runDB $ ordered1 1 2 3+    assertEqual "1+2*2+3*3 = 14" 14 b+  it "handles mixed argument style" $ withOrderedFuncs $ do+    Only b <- runDB $ ordered2 1 2 3+    assertEqual "1+3*2+2*3 = 13" 13 b+  it "handles void return type" $ withVoid $ runDB voidProc+  it "handles variadic type" $ withVariadic $ do+    res1 <- runDB $ variadicProc (Variadic $ PGArray [10, -1, 5, 4])+    assertEqual "mleast [10, -1, 5, 4] = -1" (Just $ Only (-1)) res1+    res2 <- runDB $ variadicProc (Variadic $ PGArray [])+    assertEqual "mleast [] = NULL" Nothing res2+  it "handles array type" $ withArrayFuncs $ do+    res1 <- runDB $ arrayProc (PGArray [10, -1, 5, 4])+    assertEqual "mleast [10, -1, 5, 4] = -1" (Just $ Only (-1)) res1+    res2 <- runDB $ arrayProc (PGArray [])+    assertEqual "mleast [] = NULL" Nothing res2+  it "handles default values" $ withDefaultFuncs $ do+    Only res1 <- runDB $ defaultProc (Default $ Just 1) (Default $ Just 1)+    assertEqual "1+1 = 2" 2 res1+    Only res2 <- runDB $ defaultProc (Default $ Just 1) (Default Nothing)+    assertEqual "1+0 = 1" 1 res2+    Only res3 <- runDB $ defaultProc (Default Nothing) (Default $ Just 2)+    assertEqual "0+2 = 2" 2 res3+    Only res4 <- runDB $ defaultProc (Default Nothing) (Default Nothing)+    assertEqual "0+0 = 0" 0 res4++
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+