postgresql-query 2.3.0 → 3.0.0
raw patch · 22 files changed
+1075/−855 lines, 22 filesdep +derivedep +type-fundep ~basedep ~postgresql-simple
Dependencies added: derive, type-fun
Dependency ranges changed: base, postgresql-simple
Files
- CHANGELOG.md +10/−0
- postgresql-query.cabal +22/−6
- src/Database/PostgreSQL/Query.hs +1/−8
- src/Database/PostgreSQL/Query/Entity.hs +7/−24
- src/Database/PostgreSQL/Query/Entity/Class.hs +25/−0
- src/Database/PostgreSQL/Query/Entity/Functions.hs +287/−0
- src/Database/PostgreSQL/Query/Entity/Internal.hs +207/−0
- src/Database/PostgreSQL/Query/Functions.hs +62/−302
- src/Database/PostgreSQL/Query/Internal.hs +7/−204
- src/Database/PostgreSQL/Query/SqlBuilder.hs +6/−129
- src/Database/PostgreSQL/Query/SqlBuilder/Builder.hs +90/−0
- src/Database/PostgreSQL/Query/SqlBuilder/Class.hs +19/−0
- src/Database/PostgreSQL/Query/SqlBuilder/Types.hs +64/−0
- src/Database/PostgreSQL/Query/TH.hs +0/−2
- src/Database/PostgreSQL/Query/TH/Entity.hs +1/−1
- src/Database/PostgreSQL/Query/TH/Enum.hs +5/−2
- src/Database/PostgreSQL/Query/TH/Row.hs +3/−0
- src/Database/PostgreSQL/Query/TH/SqlExp.hs +25/−48
- src/Database/PostgreSQL/Query/Types.hs +18/−9
- test/BuilderTest.hs +33/−0
- test/Main.hs +5/−120
- test/ParserTest.hs +178/−0
CHANGELOG.md view
@@ -1,5 +1,15 @@ # CHANGELOG +## 3.0.0+### Added+* Ability to mask some sensitive query arguments in query logs. In case you dont+ want someone can see your secret data in logs.+ * Added interpolation syntax `#?{argumentExpression}` for masked parameters+ * Added `pgQueryWithMasker` and `pgExecuteWithMasker` for custom log masker+* `MonadPostgres` type synonim+### Changed+* Refactoring of `SqlBuilder` and `Entity` modules+* Some low-level intefaces changed ## 2.3.0 ### Added * `derivePgEnum` TH generator for enum fields
postgresql-query.cabal view
@@ -1,5 +1,5 @@ name: postgresql-query-version: 2.3.0+version: 3.0.0 synopsis: Sql interpolating quasiquote plus some kind of primitive ORM using it@@ -25,9 +25,15 @@ exposed-modules: Database.PostgreSQL.Query , Database.PostgreSQL.Query.Entity+ , Database.PostgreSQL.Query.Entity.Class+ , Database.PostgreSQL.Query.Entity.Functions+ , Database.PostgreSQL.Query.Entity.Internal , Database.PostgreSQL.Query.Functions , Database.PostgreSQL.Query.Internal , Database.PostgreSQL.Query.SqlBuilder+ , Database.PostgreSQL.Query.SqlBuilder.Builder+ , Database.PostgreSQL.Query.SqlBuilder.Class+ , Database.PostgreSQL.Query.SqlBuilder.Types , Database.PostgreSQL.Query.TH , Database.PostgreSQL.Query.TH.Common , Database.PostgreSQL.Query.TH.Entity@@ -36,18 +42,20 @@ , Database.PostgreSQL.Query.TH.SqlExp , Database.PostgreSQL.Query.Types - default-extensions: CPP+ default-extensions: AutoDeriveTypeable+ , CPP+ , ConstraintKinds+ , DataKinds , DeriveDataTypeable , DeriveGeneric , EmptyDataDecls , FlexibleContexts , FlexibleInstances+ , FunctionalDependencies , GADTs , GeneralizedNewtypeDeriving , LambdaCase , MultiParamTypeClasses- , NoImplicitPrelude- , NoMonomorphismRestriction , OverloadedStrings , QuasiQuotes , RecordWildCards@@ -88,6 +96,7 @@ , transformers , transformers-base , transformers-compat >= 0.3+ , type-fun >= 0.1.0 ghc-options: -Wall @@ -100,15 +109,21 @@ ghc-options: -Wall hs-source-dirs: test main-is: Main.hs+ other-modules: BuilderTest+ , ParserTest - default-extensions: FlexibleInstances+ default-extensions: CPP+ , FlexibleInstances , OverloadedStrings+ , QuasiQuotes , TemplateHaskell build-depends: QuickCheck , attoparsec , base >=4.6 && < 5+ , derive , postgresql-query+ , postgresql-simple , quickcheck-assertions , quickcheck-instances , tasty@@ -124,7 +139,8 @@ hs-source-dirs: example main-is: Main.hs - default-extensions: FlexibleInstances+ default-extensions: AutoDeriveTypeable+ , FlexibleInstances , OverloadedStrings , TemplateHaskell
src/Database/PostgreSQL/Query.hs view
@@ -12,7 +12,7 @@ , FromRow(..), Query(..), Only(..), In(..), Oid(..), Values(..) , (:.)(..), PGArray(..), HStoreList(..), HStoreMap(..) , ToHStore(..), HStoreBuilder , hstore, parseHStoreList- , ToHStoreText(..), HStoreText , sqlQQ+ , ToHStoreText(..), HStoreText ) where @@ -23,19 +23,12 @@ import Database.PostgreSQL.Simple.FromRow ( FromRow(..) ) import Database.PostgreSQL.Simple.HStore hiding ( toBuilder, toLazyByteString ) -- to prevent conflicts-import Database.PostgreSQL.Simple.SqlQQ import Database.PostgreSQL.Simple.ToField ( ToField(..) ) import Database.PostgreSQL.Simple.ToRow ( ToRow(..) ) import Database.PostgreSQL.Simple.Types-import Language.Haskell.TH.Quote ( QuasiQuoter ) import Database.PostgreSQL.Query.Entity import Database.PostgreSQL.Query.Functions import Database.PostgreSQL.Query.SqlBuilder import Database.PostgreSQL.Query.TH import Database.PostgreSQL.Query.Types--sqlQQ :: QuasiQuoter-sqlQQ = sql--{-# DEPRECATED sqlQQ "Use 'sqlExp' instead" #-}
src/Database/PostgreSQL/Query/Entity.hs view
@@ -1,26 +1,9 @@ module Database.PostgreSQL.Query.Entity- ( Entity(..)- , Ent- ) where--import Data.Proxy-import Data.Text ( Text )-import Data.Typeable ( Typeable )-import Database.PostgreSQL.Query.Types---- | Auxiliary typeclass for data types which can map to rows of some--- table. This typeclass is used inside functions like 'pgSelectEntities' to--- generate queries.-class Entity a where- -- | Id type for this entity- data EntityId a :: *- -- | Table name of this entity- tableName :: Proxy a -> FN- -- | Field names without 'id' and 'created'. The order of field names must match- -- with order of fields in 'ToRow' and 'FromRow' instances of this type.- fieldNames :: Proxy a -> [FN]--deriving instance Typeable EntityId+ ( module Database.PostgreSQL.Query.Entity.Class+ , module Database.PostgreSQL.Query.Entity.Functions+ , module Database.PostgreSQL.Query.Entity.Internal+ ) where --- | Entity with it's id-type Ent a = (EntityId a, a)+import Database.PostgreSQL.Query.Entity.Class+import Database.PostgreSQL.Query.Entity.Functions+import Database.PostgreSQL.Query.Entity.Internal
+ src/Database/PostgreSQL/Query/Entity/Class.hs view
@@ -0,0 +1,25 @@+module Database.PostgreSQL.Query.Entity.Class+ ( Entity(..)+ , Ent+ ) where++import Data.Proxy+import Data.Typeable ( Typeable )+import Database.PostgreSQL.Query.Types++-- | Auxiliary typeclass for data types which can map to rows of some+-- table. This typeclass is used inside functions like 'pgSelectEntities' to+-- generate queries.+class Entity a where+ -- | Id type for this entity+ data EntityId a :: *+ -- | Table name of this entity+ tableName :: Proxy a -> FN+ -- | Field names without 'id' and 'created'. The order of field names must match+ -- with order of fields in 'ToRow' and 'FromRow' instances of this type.+ fieldNames :: Proxy a -> [FN]++deriving instance Typeable EntityId++-- | Entity with it's id+type Ent a = (EntityId a, a)
+ src/Database/PostgreSQL/Query/Entity/Functions.hs view
@@ -0,0 +1,287 @@+module Database.PostgreSQL.Query.Entity.Functions+ ( -- * Work with entities+ pgInsertEntity+ , pgInsertManyEntities+ , pgInsertManyEntitiesId+ , pgSelectEntities+ , pgSelectJustEntities+ , pgSelectEntitiesBy+ , pgGetEntity+ , pgGetEntityBy+ , pgQueryEntities+ , pgDeleteEntity+ , pgUpdateEntity+ , pgSelectCount+ ) where++import Control.Monad.Logger+import Data.Int ( Int64 )+import Data.Maybe ( listToMaybe )+import Data.Proxy ( Proxy(..) )+import Data.Typeable ( Typeable )+import Database.PostgreSQL.Query.Entity.Class+import Database.PostgreSQL.Query.Entity.Internal+import Database.PostgreSQL.Query.Functions+import Database.PostgreSQL.Query.SqlBuilder+import Database.PostgreSQL.Query.TH+ ( sqlExp )+import Database.PostgreSQL.Query.Types+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import qualified Data.List as L+import qualified Data.List.NonEmpty as NL+++-- | Insert new entity and return it's id+pgInsertEntity+ :: forall a m+ . ( MonadPostgres m, MonadLogger m, Entity a+ , ToRow a, FromField (EntityId a) )+ => a+ -> m (EntityId a)+pgInsertEntity a = do+ pgQuery [sqlExp|^{insertEntity a} RETURNING id|] >>= \case+ ((Only ret):_) -> return ret+ _ -> fail "Query did not return any response"+++{- | Select entities as pairs of (id, entity).++@+handler :: Handler [Ent a]+handler = do+ now <- liftIO getCurrentTime+ let back = addUTCTime (days (-7)) now+ pgSelectEntities id+ [sqlExp|WHERE created BETWEEN \#{now} AND \#{back}+ ORDER BY created|]++handler2 :: Text -> Handler [Ent Foo]+handler2 fvalue = do+ pgSelectEntities ("t"<>)+ [sqlExp|AS t INNER JOIN table2 AS t2+ ON t.t2_id = t2.id+ WHERE t.field = \#{fvalue}+ ORDER BY t2.field2|]+ -- Here the query will be: SELECT ... FROM tbl AS t INNER JOIN ...+@++-}++pgSelectEntities+ :: forall m a q+ . ( Functor m, MonadPostgres m, MonadLogger m, Entity a+ , FromRow a, ToSqlBuilder q, FromField (EntityId a) )+ => (FN -> FN)+ -- ^ Entity fields name modifier, e.g. ("tablename"<>). Each field of entity+ -- will be processed by this modifier before pasting to the query+ -> q+ -- ^ part of query just after __SELECT .. FROM table__.+ -> m [Ent a]+pgSelectEntities fpref q = do+ let p = Proxy :: Proxy a+ pgQueryEntities [sqlExp|^{selectEntity (entityFieldsId fpref) p} ^{q}|]+++-- | Same as 'pgSelectEntities' but do not select id+pgSelectJustEntities+ :: forall m a q+ . ( Functor m, MonadPostgres m, MonadLogger m, Entity a+ , FromRow a, ToSqlBuilder q )+ => (FN -> FN)+ -> q+ -> m [a]+pgSelectJustEntities fpref q = do+ let p = Proxy :: Proxy a+ pgQuery [sqlExp|^{selectEntity (entityFields id fpref) p} ^{q}|]++{- | Select entities by condition formed from 'MarkedRow'. Usefull function when+you know++-}++pgSelectEntitiesBy+ :: forall a m b+ . ( Functor m, MonadPostgres m, MonadLogger m, Entity a, ToMarkedRow b+ , FromRow a, FromField (EntityId a) )+ => b+ -> m [Ent a]+pgSelectEntitiesBy b =+ let p = Proxy :: Proxy a+ in pgQueryEntities $ selectEntitiesBy ("id":) p b+++-- | Select entity by id+--+-- @+-- getUser :: EntityId User -> Handler User+-- getUser uid = do+-- pgGetEntity uid+-- >>= maybe notFound return+-- @+pgGetEntity+ :: forall m a+ . ( ToField (EntityId a), Entity a, FromRow a+ , MonadPostgres m, MonadLogger m, Functor m)+ => EntityId a+ -> m (Maybe a)+pgGetEntity eid = do+ listToMaybe <$> pgSelectJustEntities id [sqlExp|WHERE id = #{eid} LIMIT 1|]+++{- | Get entity by some fields constraint++@+getUser :: UserName -> Handler User+getUser name = do+ pgGetEntityBy+ (MR [("name", mkValue name),+ ("active", mkValue True)])+ >>= maybe notFound return+@++The query here will be like++@+pgQuery [sqlExp|SELECT id, name, phone ... FROM users WHERE name = #{name} AND active = #{True}|]+@++-}++pgGetEntityBy+ :: forall m a b+ . ( Entity a, MonadPostgres m, MonadLogger m, ToMarkedRow b+ , FromField (EntityId a), FromRow a, Functor m )+ => b -- ^ uniq constrained list of fields and values+ -> m (Maybe (Ent a))+pgGetEntityBy b =+ let p = Proxy :: Proxy a+ in fmap listToMaybe+ $ pgQueryEntities+ [sqlExp|^{selectEntitiesBy ("id":) p b} LIMIT 1|]+++-- | Same as 'pgInsertEntity' but insert many entities at one+-- action. Returns list of id's of inserted entities+pgInsertManyEntitiesId+ :: forall a m+ . ( Entity a, MonadPostgres m, MonadLogger m+ , ToRow a, FromField (EntityId a))+ => [a]+ -> m [EntityId a]+pgInsertManyEntitiesId [] = return []+pgInsertManyEntitiesId ents' =+ let ents = NL.fromList ents'+ q = [sqlExp|^{insertManyEntities ents} RETURNING id|]+ in map fromOnly <$> pgQuery q++-- | Insert many entities without returning list of id like+-- 'pgInsertManyEntitiesId' does+pgInsertManyEntities+ :: forall a m+ . (Entity a, MonadPostgres m, MonadLogger m, ToRow a)+ => [a]+ -> m Int64+pgInsertManyEntities [] = return 0+pgInsertManyEntities ents' =+ let ents = NL.fromList ents'+ in pgExecute $ insertManyEntities ents+++{- | Delete entity.++@+rmUser :: EntityId User -> Handler ()+rmUser uid = do+ pgDeleteEntity uid+@++Return 'True' if row was actually deleted.+-}++pgDeleteEntity+ :: forall a m+ . (Entity a, MonadPostgres m, MonadLogger m, ToField (EntityId a), Functor m)+ => EntityId a+ -> m Bool+pgDeleteEntity eid =+ let p = Proxy :: Proxy a+ in fmap (1 ==)+ $ pgExecute [sqlExp|DELETE FROM ^{tableName p}+ WHERE id = #{eid}|]+++{- | Update entity using 'ToMarkedRow' instanced value. Requires 'Proxy'+while 'EntityId' is not a data type.++@+fixUser :: Text -> EntityId User -> Handler ()+fixUser username uid = do+ pgGetEntity uid+ >>= maybe notFound run+ where+ run user =+ pgUpdateEntity uid+ $ MR [("active", mkValue True)+ ("name", mkValue username)]+@++Returns 'True' if record was actually updated and 'False' if there was+not row with such id (or was more than 1, in fact)+-}++pgUpdateEntity+ :: forall a b m+ . ( ToMarkedRow b, Entity a, MonadPostgres m, MonadLogger m+ , ToField (EntityId a), Functor m, Typeable a, Typeable b)+ => EntityId a+ -> b+ -> m Bool+pgUpdateEntity eid b =+ let p = Proxy :: Proxy a+ mr = toMarkedRow b+ in if L.null $ unMR mr+ then return False+ else fmap (1 ==)+ $ pgExecute [sqlExp|UPDATE ^{tableName p}+ SET ^{mrToBuilder ", " mr}+ WHERE id = #{eid}|]++{- | Select count of entities with given query++@+activeUsers :: Handler Integer+activeUsers = do+ pgSelectCount (Proxy :: Proxy User)+ [sqlExp|WHERE active = #{True}|]+@++-}+++-- | Executes arbitrary query and parses it as entities and their ids+pgQueryEntities+ :: ( ToSqlBuilder q, MonadPostgres m, MonadLogger m, Entity a+ , FromRow a, FromField (EntityId a))+ => q+ -> m [Ent a]+pgQueryEntities q =+ map toTuples <$> pgQuery q+ where+ toTuples ((Only eid) :. entity) = (eid, entity)++pgSelectCount+ :: forall m a q+ . ( Entity a, MonadPostgres m, MonadLogger m, ToSqlBuilder q )+ => Proxy a+ -> q+ -> m Integer+pgSelectCount p q = do+ [[c]] <- pgQuery [sqlExp|SELECT count(id) FROM ^{tableName p} ^{q}|]+ return c
+ src/Database/PostgreSQL/Query/Entity/Internal.hs view
@@ -0,0 +1,207 @@+module Database.PostgreSQL.Query.Entity.Internal+ ( -- * Entity functions+ entityFields+ , entityFieldsId+ , selectEntity+ , selectEntitiesBy+ , insertEntity+ , insertManyEntities+ , entityToMR+ ) where++import Data.List.NonEmpty ( NonEmpty )+import Data.Monoid+import Data.Proxy ( Proxy(..) )+import Database.PostgreSQL.Query.Entity.Class+import Database.PostgreSQL.Query.Internal+import Database.PostgreSQL.Query.SqlBuilder+ ( SqlBuilder, ToSqlBuilder(..), mkValue )+import Database.PostgreSQL.Query.TH+ ( sqlExp )+import Database.PostgreSQL.Query.Types+ ( FN(..), MarkedRow(..),+ ToMarkedRow(..), mrToBuilder )+import Database.PostgreSQL.Simple.ToRow+ ( ToRow(..) )++import qualified Data.List.NonEmpty as NL+import qualified Data.List as L+++{- | Build entity fields++>>> data Foo = Foo { fName :: Text, fSize :: Int }+>>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}+>>> runSqlBuilder con $ entityFields id id (Proxy :: Proxy Foo)+"\"name\", \"size\""++>>> runSqlBuilder con $ entityFields ("id":) id (Proxy :: Proxy Foo)+"\"id\", \"name\", \"size\""++>>> runSqlBuilder con $ entityFields (\l -> ("id":l) ++ ["created"]) id (Proxy :: Proxy Foo)+"\"id\", \"name\", \"size\", \"created\""++>>> runSqlBuilder con $ entityFields id ("f"<>) (Proxy :: Proxy Foo)+"\"f\".\"name\", \"f\".\"size\""++>>> runSqlBuilder con $ entityFields ("f.id":) ("f"<>) (Proxy :: Proxy Foo)+"\"f\".\"id\", \"f\".\"name\", \"f\".\"size\""++-}++entityFields :: (Entity a)+ => ([FN] -> [FN]) -- ^ modify list of fields. Applied second+ -> (FN -> FN) -- ^ modify each field name,+ -- e.g. prepend each field with+ -- prefix, like ("t"<>). Applied first+ -> Proxy a+ -> SqlBuilder+entityFields xpref fpref p =+ buildFields+ $ xpref+ $ map fpref+ $ fieldNames p++{- | Same as 'entityFields' but prefixes list of names with __id__+field. This is shorthand function for often usage.++>>> data Foo = Foo { fName :: Text, fSize :: Int }+>>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}+>>> runSqlBuilder con $ entityFieldsId id (Proxy :: Proxy Foo)+"\"id\", \"name\", \"size\""++>>> runSqlBuilder con $ entityFieldsId ("f"<>) (Proxy :: Proxy Foo)+"\"f\".\"id\", \"f\".\"name\", \"f\".\"size\""++-}++entityFieldsId :: (Entity a)+ => (FN -> FN)+ -> Proxy a+ -> SqlBuilder+entityFieldsId fpref p =+ let xpref = ((fpref "id"):)+ in entityFields xpref fpref p++{- | Generate SELECT query string for entity++>>> data Foo = Foo { fName :: Text, fSize :: Int }+>>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}+>>> runSqlBuilder con $ selectEntity (entityFieldsId id) (Proxy :: Proxy Foo)+"SELECT \"id\", \"name\", \"size\" FROM \"foo\""++>>> runSqlBuilder con $ selectEntity (entityFieldsId ("f"<>)) (Proxy :: Proxy Foo)+"SELECT \"f\".\"id\", \"f\".\"name\", \"f\".\"size\" FROM \"foo\""++>>> runSqlBuilder con $ selectEntity (entityFields id id) (Proxy :: Proxy Foo)+"SELECT \"name\", \"size\" FROM \"foo\""++-}++selectEntity :: (Entity a)+ => (Proxy a -> SqlBuilder) -- ^ build fields part from proxy+ -> Proxy a+ -> SqlBuilder+selectEntity bld p =+ [sqlExp|SELECT ^{bld p} FROM ^{tableName p}|]+++{- | Generates SELECT FROM WHERE query with most used conditions++>>> data Foo = Foo { fName :: Text, fSize :: Int }+>>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}+>>> runSqlBuilder con $ selectEntitiesBy id (Proxy :: Proxy Foo) $ MR []+"SELECT \"name\", \"size\" FROM \"foo\""++>>> runSqlBuilder con $ selectEntitiesBy id (Proxy :: Proxy Foo) $ MR [("name", mkValue "fooname")]+"SELECT \"name\", \"size\" FROM \"foo\" WHERE \"name\" = 'fooname' "++>>> runSqlBuilder con $ selectEntitiesBy id (Proxy :: Proxy Foo) $ MR [("name", mkValue "fooname"), ("size", mkValue 10)]+"SELECT \"name\", \"size\" FROM \"foo\" WHERE \"name\" = 'fooname' AND \"size\" = 10 "++-}++selectEntitiesBy :: (Entity a, ToMarkedRow b)+ => ([FN] -> [FN])+ -> Proxy a+ -> b+ -> SqlBuilder+selectEntitiesBy xpref p b =+ let mr = toMarkedRow b+ cond = if L.null $ unMR mr+ then mempty+ else [sqlExp| WHERE ^{mrToBuilder "AND" mr}|]+ q = selectEntity (entityFields xpref id) p+ in q <> cond++++{- | Convert entity instance to marked row to perform inserts updates+and same stuff++>>> data Foo = Foo { fName :: Text, fSize :: Int }+>>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}+>>> instance ToRow Foo where { toRow Foo{..} = [toField fName, toField fSize] }+>>> runSqlBuilder con $ mrToBuilder ", " $ entityToMR $ Foo "Enterprise" 610+" \"name\" = 'Enterprise' , \"size\" = 610 "++-}++entityToMR :: forall a. (Entity a, ToRow a) => a -> MarkedRow+entityToMR a =+ let p = Proxy :: Proxy a+ names = fieldNames p+ values = map mkValue $ toRow a+ in MR $ zip names values+++{- | Generates __INSERT INTO__ query for any instance of 'Entity' and 'ToRow'++>>> data Foo = Foo { fName :: Text, fSize :: Int }+>>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}+>>> instance ToRow Foo where { toRow Foo{..} = [toField fName, toField fSize] }+>>> runSqlBuilder con $ insertEntity $ Foo "Enterprise" 910+"INSERT INTO \"foo\" (\"name\", \"size\") VALUES ('Enterprise', 910)"++-}++insertEntity :: forall a. (Entity a, ToRow a) => a -> SqlBuilder+insertEntity a =+ let p = Proxy :: Proxy a+ mr = entityToMR a+ in insertInto (tableName p) mr++{- | Same as 'insertEntity' but generates query to insert many queries at same time++>>> data Foo = Foo { fName :: Text, fSize :: Int }+>>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}+>>> instance ToRow Foo where { toRow Foo{..} = [toField fName, toField fSize] }+>>> runSqlBuilder con $ insertManyEntities $ NL.fromList [Foo "meter" 1, Foo "table" 2, Foo "earth" 151930000000]+"INSERT INTO \"foo\" (\"name\",\"size\") VALUES ('meter',1),('table',2),('earth',151930000000)"++-}++insertManyEntities :: forall a. (Entity a, ToRow a)+ => NonEmpty a+ -> SqlBuilder+insertManyEntities rows =+ let p = Proxy :: Proxy a+ names = mconcat+ $ L.intersperse ","+ $ map toSqlBuilder+ $ fieldNames p+ values = mconcat+ $ L.intersperse ","+ $ map rValue+ $ NL.toList rows++ in [sqlExp|INSERT INTO ^{tableName p}+ (^{names}) VALUES ^{values}|]+ where+ rValue :: a -> SqlBuilder+ rValue row =+ let values = mconcat+ $ L.intersperse ","+ $ map mkValue+ $ toRow row+ in [sqlExp|(^{values})|]
src/Database/PostgreSQL/Query/Functions.hs view
@@ -1,71 +1,86 @@ module Database.PostgreSQL.Query.Functions ( -- * Raw query execution pgQuery+ , pgQueryWithMasker , pgExecute- , pgQueryEntities+ , pgExecuteWithMasker -- * Transactions , pgWithTransaction , pgWithSavepoint , pgWithTransactionMode , pgWithTransactionModeRetry , pgWithTransactionSerializable- -- * Work with entities- , pgInsertEntity- , pgInsertManyEntities- , pgInsertManyEntitiesId- , pgSelectEntities- , pgSelectJustEntities- , pgSelectEntitiesBy- , pgGetEntity- , pgGetEntityBy- , pgDeleteEntity- , pgUpdateEntity- , pgSelectCount- -- * Auxiliary functions+ -- * Auxiliary , pgRepsertRow ) where -import Prelude--import Control.Applicative import Control.Monad import Control.Monad.Base import Control.Monad.Logger import Control.Monad.Trans.Control import Data.Int ( Int64 )-import Data.Maybe ( listToMaybe ) import Data.Monoid-import Data.Proxy ( Proxy(..) )-import Data.Typeable ( Typeable )-import Database.PostgreSQL.Query.Entity- ( Entity(..), Ent ) import Database.PostgreSQL.Query.Internal- ( insertEntity, selectEntity, entityFieldsId,- entityFields, selectEntitiesBy, insertManyEntities,- updateTable, insertInto ) import Database.PostgreSQL.Query.SqlBuilder- ( ToSqlBuilder(..), runSqlBuilder ) import Database.PostgreSQL.Query.TH- ( sqlExp ) import Database.PostgreSQL.Query.Types- ( FN, HasPostgres(..), TransactionSafe,- ToMarkedRow(..), MarkedRow(..), mrToBuilder ) import Database.PostgreSQL.Simple- ( ToRow, FromRow, execute_, query_, )-import Database.PostgreSQL.Simple.FromField- ( FromField )-import Database.PostgreSQL.Simple.Internal- ( SqlError )-import Database.PostgreSQL.Simple.ToField- ( ToField ) import Database.PostgreSQL.Simple.Transaction-import Database.PostgreSQL.Simple.Types- ( Query(..), Only(..), (:.)(..) ) -import qualified Data.List as L-import qualified Data.List.NonEmpty as NL import qualified Data.Text.Encoding as T +{- | Execute query generated by 'SqlBuilder'. Typical use case:++@+let userName = "Vovka Erohin" :: Text+pgQuery [sqlExp| SELECT id, name FROM users WHERE name = #{userName}|]+@++Or++@+let userName = "Vovka Erohin" :: Text+pgQuery $ Qp "SELECT id, name FROM users WHERE name = ?" [userName]+@++Which is almost the same. In both cases proper value escaping is performed+so you stay protected from sql injections.++-}++pgQuery+ :: (HasPostgres m, MonadLogger m, ToSqlBuilder q, FromRow r)+ => q+ -> m [r]+pgQuery = pgQueryWithMasker defaultLogMasker++-- | Execute arbitrary query and return count of affected rows+pgExecute+ :: (HasPostgres m, MonadLogger m, ToSqlBuilder q)+ => q+ -> m Int64+pgExecute = pgExecuteWithMasker defaultLogMasker++pgQueryWithMasker+ :: (HasPostgres m, MonadLogger m, ToSqlBuilder q, FromRow r)+ => LogMasker+ -> q+ -> m [r]+pgQueryWithMasker masker q = withPGConnection $ \c -> do+ (queryBs, logBs) <- liftBase $ runSqlBuilder c masker $ toSqlBuilder q+ logDebugN $ T.decodeUtf8 logBs+ liftBase $ query_ c queryBs++pgExecuteWithMasker+ :: (HasPostgres m, MonadLogger m, ToSqlBuilder q)+ => LogMasker+ -> q+ -> m Int64+pgExecuteWithMasker masker q = withPGConnection $ \c -> do+ (queryBs, logBs) <- liftBase $ runSqlBuilder c masker $ toSqlBuilder q+ logDebugN $ T.decodeUtf8 logBs+ liftBase $ execute_ c queryBs+ -- | Execute all queries inside one transaction. Rollback transaction on exceptions pgWithTransaction :: (HasPostgres m, MonadBaseControl IO m, TransactionSafe m) => m a@@ -122,265 +137,8 @@ control $ \runInIO -> do withTransactionSerializable con $ runInIO ma -{- | Execute query generated by 'SqlBuilder'. Typical use case: -@-let userName = "Vovka Erohin" :: Text-pgQuery [sqlExp| SELECT id, name FROM users WHERE name = #{userName}|]-@ -Or--@-let userName = "Vovka Erohin" :: Text-pgQuery $ Qp "SELECT id, name FROM users WHERE name = ?" [userName]-@--Which is almost the same. In both cases proper value escaping is performed-so you stay protected from sql injections.---}--pgQuery :: (HasPostgres m, MonadLogger m, ToSqlBuilder q, FromRow r)- => q -> m [r]-pgQuery q = withPGConnection $ \c -> do- b <- liftBase $ runSqlBuilder c $ toSqlBuilder q- logDebugN $ T.decodeUtf8 $ fromQuery b- liftBase $ query_ c b---- | Execute arbitrary query and return count of affected rows-pgExecute :: (HasPostgres m, MonadLogger m, ToSqlBuilder q)- => q -> m Int64-pgExecute q = withPGConnection $ \c -> do- b <- liftBase $ runSqlBuilder c $ toSqlBuilder q- logDebugN $ T.decodeUtf8 $ fromQuery b- liftBase $ execute_ c b---- | Executes arbitrary query and parses it as entities and their ids-pgQueryEntities :: ( ToSqlBuilder q, HasPostgres m, MonadLogger m, Entity a- , FromRow a, FromField (EntityId a))- => q -> m [Ent a]-pgQueryEntities q =- map toTuples <$> pgQuery q- where- toTuples ((Only eid) :. entity) = (eid, entity)----- | Insert new entity and return it's id-pgInsertEntity :: forall a m. (HasPostgres m, MonadLogger m, Entity a,- ToRow a, FromField (EntityId a))- => a- -> m (EntityId a)-pgInsertEntity a = do- pgQuery [sqlExp|^{insertEntity a} RETURNING id|] >>= \case- ((Only ret):_) -> return ret- _ -> fail "Query did not return any response"---{- | Select entities as pairs of (id, entity).--@-handler :: Handler [Ent a]-handler = do- now <- liftIO getCurrentTime- let back = addUTCTime (days (-7)) now- pgSelectEntities id- [sqlExp|WHERE created BETWEEN \#{now} AND \#{back}- ORDER BY created|]--handler2 :: Text -> Handler [Ent Foo]-handler2 fvalue = do- pgSelectEntities ("t"<>)- [sqlExp|AS t INNER JOIN table2 AS t2- ON t.t2_id = t2.id- WHERE t.field = \#{fvalue}- ORDER BY t2.field2|]- -- Here the query will be: SELECT ... FROM tbl AS t INNER JOIN ...-@---}--pgSelectEntities :: forall m a q. ( Functor m, HasPostgres m, MonadLogger m, Entity a- , FromRow a, ToSqlBuilder q, FromField (EntityId a) )- => (FN -> FN) -- ^ Entity fields name modifier,- -- e.g. ("tablename"<>). Each field of- -- entity will be processed by this- -- modifier before pasting to the query- -> q -- ^ part of query just after __SELECT .. FROM table__.- -> m [Ent a]-pgSelectEntities fpref q = do- let p = Proxy :: Proxy a- pgQueryEntities [sqlExp|^{selectEntity (entityFieldsId fpref) p} ^{q}|]----- | Same as 'pgSelectEntities' but do not select id-pgSelectJustEntities :: forall m a q. ( Functor m, HasPostgres m, MonadLogger m, Entity a- , FromRow a, ToSqlBuilder q )- => (FN -> FN)- -> q- -> m [a]-pgSelectJustEntities fpref q = do- let p = Proxy :: Proxy a- pgQuery [sqlExp|^{selectEntity (entityFields id fpref) p} ^{q}|]--{- | Select entities by condition formed from 'MarkedRow'. Usefull function when you know---}--pgSelectEntitiesBy :: forall a m b.( Functor m, HasPostgres m, MonadLogger m, Entity a, ToMarkedRow b- , FromRow a, FromField (EntityId a) )- => b- -> m [Ent a]-pgSelectEntitiesBy b =- let p = Proxy :: Proxy a- in pgQueryEntities $ selectEntitiesBy ("id":) p b----- | Select entity by id------ @--- getUser :: EntityId User -> Handler User--- getUser uid = do--- pgGetEntity uid--- >>= maybe notFound return--- @-pgGetEntity :: forall m a. (ToField (EntityId a), Entity a,- HasPostgres m, MonadLogger m, FromRow a, Functor m)- => EntityId a- -> m (Maybe a)-pgGetEntity eid = do- listToMaybe <$> pgSelectJustEntities id [sqlExp|WHERE id = #{eid} LIMIT 1|]---{- | Get entity by some fields constraint--@-getUser :: UserName -> Handler User-getUser name = do- pgGetEntityBy- (MR [("name", mkValue name),- ("active", mkValue True)])- >>= maybe notFound return-@--The query here will be like--@-pgQuery [sqlExp|SELECT id, name, phone ... FROM users WHERE name = #{name} AND active = #{True}|]-@---}--pgGetEntityBy :: forall m a b. ( Entity a, HasPostgres m, MonadLogger m, ToMarkedRow b- , FromField (EntityId a), FromRow a, Functor m )- => b -- ^ uniq constrained list of fields and values- -> m (Maybe (Ent a))-pgGetEntityBy b =- let p = Proxy :: Proxy a- in fmap listToMaybe- $ pgQueryEntities- [sqlExp|^{selectEntitiesBy ("id":) p b} LIMIT 1|]----- | Same as 'pgInsertEntity' but insert many entities at one--- action. Returns list of id's of inserted entities-pgInsertManyEntitiesId :: forall a m. ( Entity a, HasPostgres m, MonadLogger m- , ToRow a, FromField (EntityId a))- => [a]- -> m [EntityId a]-pgInsertManyEntitiesId [] = return []-pgInsertManyEntitiesId ents' =- let ents = NL.fromList ents'- q = [sqlExp|^{insertManyEntities ents} RETURNING id|]- in map fromOnly <$> pgQuery q---- | Insert many entities without returning list of id like--- 'pgInsertManyEntitiesId' does-pgInsertManyEntities :: forall a m. (Entity a, HasPostgres m, MonadLogger m, ToRow a)- => [a]- -> m Int64-pgInsertManyEntities [] = return 0-pgInsertManyEntities ents' =- let ents = NL.fromList ents'- in pgExecute $ insertManyEntities ents---{- | Delete entity.--@-rmUser :: EntityId User -> Handler ()-rmUser uid = do- pgDeleteEntity uid-@--Return 'True' if row was actually deleted.--}--pgDeleteEntity :: forall a m. (Entity a, HasPostgres m, MonadLogger m, ToField (EntityId a), Functor m)- => EntityId a- -> m Bool-pgDeleteEntity eid =- let p = Proxy :: Proxy a- in fmap (1 ==)- $ pgExecute [sqlExp|DELETE FROM ^{tableName p}- WHERE id = #{eid}|]---{- | Update entity using 'ToMarkedRow' instanced value. Requires 'Proxy'-while 'EntityId' is not a data type.--@-fixUser :: Text -> EntityId User -> Handler ()-fixUser username uid = do- pgGetEntity uid- >>= maybe notFound run- where- run user =- pgUpdateEntity uid- $ MR [("active", mkValue True)- ("name", mkValue username)]-@--Returns 'True' if record was actually updated and 'False' if there was-not row with such id (or was more than 1, in fact)--}--pgUpdateEntity :: forall a b m. (ToMarkedRow b, Entity a, HasPostgres m, MonadLogger m,- ToField (EntityId a), Functor m, Typeable a, Typeable b)- => EntityId a- -> b- -> m Bool-pgUpdateEntity eid b =- let p = Proxy :: Proxy a- mr = toMarkedRow b- in if L.null $ unMR mr- then return False- else fmap (1 ==)- $ pgExecute [sqlExp|UPDATE ^{tableName p}- SET ^{mrToBuilder ", " mr}- WHERE id = #{eid}|]--{- | Select count of entities with given query--@-activeUsers :: Handler Integer-activeUsers = do- pgSelectCount (Proxy :: Proxy User)- [sqlExp|WHERE active = #{True}|]-@---}--pgSelectCount :: forall m a q. ( Entity a, HasPostgres m, MonadLogger m, ToSqlBuilder q )- => Proxy a- -> q- -> m Integer-pgSelectCount p q = do- [[c]] <- pgQuery [sqlExp|SELECT count(id) FROM ^{tableName p} ^{q}|]- return c--- {- | Perform repsert of the same row, first trying "update where" then "insert" with concatenated fields. Which means that if you run @@ -404,11 +162,13 @@ -} -pgRepsertRow :: (HasPostgres m, MonadLogger m, ToMarkedRow wrow, ToMarkedRow urow)- => FN -- ^ Table name- -> wrow -- ^ where condition- -> urow -- ^ update row- -> m ()+pgRepsertRow+ :: ( MonadPostgres m, MonadLogger m+ , ToMarkedRow wrow, ToMarkedRow urow)+ => FN -- ^ Table name+ -> wrow -- ^ where condition+ -> urow -- ^ update row+ -> m () pgRepsertRow tname wrow urow = do let wmr = toMarkedRow wrow aff <- pgExecute $ updateTable tname urow
src/Database/PostgreSQL/Query/Internal.hs view
@@ -1,37 +1,19 @@ module Database.PostgreSQL.Query.Internal- ( -- * Entity functions- entityFields- , entityFieldsId- , selectEntity- , selectEntitiesBy- , insertEntity- , insertManyEntities- , entityToMR- -- * Low level generators- , buildFields+ ( -- * Low level generators+ buildFields , updateTable , insertInto ) where --import Prelude--import Data.List.NonEmpty ( NonEmpty )-import Data.Monoid-import Data.Proxy ( Proxy(..) )-import Database.PostgreSQL.Query.Entity- ( Entity(..) ) import Database.PostgreSQL.Query.SqlBuilder- ( SqlBuilder, ToSqlBuilder(..), mkValue ) import Database.PostgreSQL.Query.TH- ( sqlExp ) import Database.PostgreSQL.Query.Types- ( FN(..), MarkedRow(..),- ToMarkedRow(..), mrToBuilder )-import Database.PostgreSQL.Simple.ToRow- ( ToRow(..) ) -import qualified Data.List.NonEmpty as NL+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif++ import qualified Data.List as L {- $setup@@ -96,182 +78,3 @@ $ unMR mr in [sqlExp|INSERT INTO ^{tname} (^{names}) VALUES (^{values})|]---{- | Build entity fields-->>> data Foo = Foo { fName :: Text, fSize :: Int }->>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}->>> runSqlBuilder con $ entityFields id id (Proxy :: Proxy Foo)-"\"name\", \"size\""-->>> runSqlBuilder con $ entityFields ("id":) id (Proxy :: Proxy Foo)-"\"id\", \"name\", \"size\""-->>> runSqlBuilder con $ entityFields (\l -> ("id":l) ++ ["created"]) id (Proxy :: Proxy Foo)-"\"id\", \"name\", \"size\", \"created\""-->>> runSqlBuilder con $ entityFields id ("f"<>) (Proxy :: Proxy Foo)-"\"f\".\"name\", \"f\".\"size\""-->>> runSqlBuilder con $ entityFields ("f.id":) ("f"<>) (Proxy :: Proxy Foo)-"\"f\".\"id\", \"f\".\"name\", \"f\".\"size\""---}--entityFields :: (Entity a)- => ([FN] -> [FN]) -- ^ modify list of fields. Applied second- -> (FN -> FN) -- ^ modify each field name,- -- e.g. prepend each field with- -- prefix, like ("t"<>). Applied first- -> Proxy a- -> SqlBuilder-entityFields xpref fpref p =- buildFields- $ xpref- $ map fpref- $ fieldNames p--{- | Same as 'entityFields' but prefixes list of names with __id__-field. This is shorthand function for often usage.-->>> data Foo = Foo { fName :: Text, fSize :: Int }->>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}->>> runSqlBuilder con $ entityFieldsId id (Proxy :: Proxy Foo)-"\"id\", \"name\", \"size\""-->>> runSqlBuilder con $ entityFieldsId ("f"<>) (Proxy :: Proxy Foo)-"\"f\".\"id\", \"f\".\"name\", \"f\".\"size\""---}--entityFieldsId :: (Entity a)- => (FN -> FN)- -> Proxy a- -> SqlBuilder-entityFieldsId fpref p =- let xpref = ((fpref "id"):)- in entityFields xpref fpref p--{- | Generate SELECT query string for entity-->>> data Foo = Foo { fName :: Text, fSize :: Int }->>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}->>> runSqlBuilder con $ selectEntity (entityFieldsId id) (Proxy :: Proxy Foo)-"SELECT \"id\", \"name\", \"size\" FROM \"foo\""-->>> runSqlBuilder con $ selectEntity (entityFieldsId ("f"<>)) (Proxy :: Proxy Foo)-"SELECT \"f\".\"id\", \"f\".\"name\", \"f\".\"size\" FROM \"foo\""-->>> runSqlBuilder con $ selectEntity (entityFields id id) (Proxy :: Proxy Foo)-"SELECT \"name\", \"size\" FROM \"foo\""---}--selectEntity :: (Entity a)- => (Proxy a -> SqlBuilder) -- ^ build fields part from proxy- -> Proxy a- -> SqlBuilder-selectEntity bld p =- [sqlExp|SELECT ^{bld p} FROM ^{tableName p}|]---{- | Generates SELECT FROM WHERE query with most used conditions-->>> data Foo = Foo { fName :: Text, fSize :: Int }->>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}->>> runSqlBuilder con $ selectEntitiesBy id (Proxy :: Proxy Foo) $ MR []-"SELECT \"name\", \"size\" FROM \"foo\""-->>> runSqlBuilder con $ selectEntitiesBy id (Proxy :: Proxy Foo) $ MR [("name", mkValue "fooname")]-"SELECT \"name\", \"size\" FROM \"foo\" WHERE \"name\" = 'fooname' "-->>> runSqlBuilder con $ selectEntitiesBy id (Proxy :: Proxy Foo) $ MR [("name", mkValue "fooname"), ("size", mkValue 10)]-"SELECT \"name\", \"size\" FROM \"foo\" WHERE \"name\" = 'fooname' AND \"size\" = 10 "---}--selectEntitiesBy :: (Entity a, ToMarkedRow b)- => ([FN] -> [FN])- -> Proxy a- -> b- -> SqlBuilder-selectEntitiesBy xpref p b =- let mr = toMarkedRow b- cond = if L.null $ unMR mr- then mempty- else [sqlExp| WHERE ^{mrToBuilder "AND" mr}|]- q = selectEntity (entityFields xpref id) p- in q <> cond----{- | Convert entity instance to marked row to perform inserts updates-and same stuff-->>> data Foo = Foo { fName :: Text, fSize :: Int }->>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}->>> instance ToRow Foo where { toRow Foo{..} = [toField fName, toField fSize] }->>> runSqlBuilder con $ mrToBuilder ", " $ entityToMR $ Foo "Enterprise" 610-" \"name\" = 'Enterprise' , \"size\" = 610 "---}--entityToMR :: forall a. (Entity a, ToRow a) => a -> MarkedRow-entityToMR a =- let p = Proxy :: Proxy a- names = fieldNames p- values = map mkValue $ toRow a- in MR $ zip names values---{- | Generates __INSERT INTO__ query for any instance of 'Entity' and 'ToRow'-->>> data Foo = Foo { fName :: Text, fSize :: Int }->>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}->>> instance ToRow Foo where { toRow Foo{..} = [toField fName, toField fSize] }->>> runSqlBuilder con $ insertEntity $ Foo "Enterprise" 910-"INSERT INTO \"foo\" (\"name\", \"size\") VALUES ('Enterprise', 910)"---}--insertEntity :: forall a. (Entity a, ToRow a) => a -> SqlBuilder-insertEntity a =- let p = Proxy :: Proxy a- mr = entityToMR a- in insertInto (tableName p) mr--{- | Same as 'insertEntity' but generates query to insert many queries at same time-->>> data Foo = Foo { fName :: Text, fSize :: Int }->>> instance Entity Foo where {newtype EntityId Foo = FooId Int ; fieldNames _ = ["name", "size"] ; tableName _ = "foo"}->>> instance ToRow Foo where { toRow Foo{..} = [toField fName, toField fSize] }->>> runSqlBuilder con $ insertManyEntities $ NL.fromList [Foo "meter" 1, Foo "table" 2, Foo "earth" 151930000000]-"INSERT INTO \"foo\" (\"name\",\"size\") VALUES ('meter',1),('table',2),('earth',151930000000)"---}--insertManyEntities :: forall a. (Entity a, ToRow a)- => NonEmpty a- -> SqlBuilder-insertManyEntities rows =- let p = Proxy :: Proxy a- names = mconcat- $ L.intersperse ","- $ map toSqlBuilder- $ fieldNames p- values = mconcat- $ L.intersperse ","- $ map rValue- $ NL.toList rows-- in [sqlExp|INSERT INTO ^{tableName p}- (^{names}) VALUES ^{values}|]- where- rValue :: a -> SqlBuilder- rValue row =- let values = mconcat- $ L.intersperse ","- $ map mkValue- $ toRow row- in [sqlExp|(^{values})|]
src/Database/PostgreSQL/Query/SqlBuilder.hs view
@@ -1,132 +1,9 @@ module Database.PostgreSQL.Query.SqlBuilder- ( -- * Types- SqlBuilder(..)- , ToSqlBuilder(..)- , Qp(..)- -- * SqlBuilder helpers- , emptyB- , runSqlBuilder- , mkIdent- , mkValue- , sqlBuilderPure- , sqlBuilderFromField+ ( module Database.PostgreSQL.Query.SqlBuilder.Builder+ , module Database.PostgreSQL.Query.SqlBuilder.Class+ , module Database.PostgreSQL.Query.SqlBuilder.Types ) where -import Prelude--import Blaze.ByteString.Builder- ( Builder, toByteString )-import Control.Applicative-import Data.ByteString ( ByteString )-import Data.Monoid-import Data.String-import Data.Text ( Text )-import Data.Typeable ( Typeable )-import Database.PostgreSQL.Simple-import Database.PostgreSQL.Simple.Internal- ( buildAction )-import Database.PostgreSQL.Simple.ToField-import Database.PostgreSQL.Simple.Types- ( Query(..), Identifier(..) )-import GHC.Generics ( Generic )--import qualified Blaze.ByteString.Builder.ByteString as BB-import qualified Blaze.ByteString.Builder.Char.Utf8 as BB-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--{- $setup->>> c <- connect defaultConnectInfo--}---- | Things which always can be transformed to 'SqlBuilder'-class ToSqlBuilder a where- toSqlBuilder :: a -> SqlBuilder---- | Special constructor to perform old-style query interpolation-data Qp = forall row. (ToRow row) => Qp Query row--instance ToSqlBuilder Qp where- toSqlBuilder (Qp q row) = SqlBuilder $ \c ->- BB.fromByteString <$> formatQuery c q row----- | Builder wich can be effectively concatenated. Requires 'Connection'--- inside for string quoting implemented in __libpq__-newtype SqlBuilder =- SqlBuilder- { sqlBuild :: Connection -> IO Builder }- deriving (Typeable, Generic)---- | Typed synonym of 'mempty'-emptyB :: SqlBuilder-emptyB = mempty--{- | Performs parameters interpolation and return ready to execute query-->>> let val = 10->>> let name = "field"->>> runSqlBuilder c $ "SELECT * FROM tbl WHERE " <> mkIdent name <> " = " <> mkValue val-"SELECT * FROM tbl WHERE \"field\" = 10"---}--runSqlBuilder :: Connection -> SqlBuilder -> IO Query-runSqlBuilder con (SqlBuilder bld) =- (Query . toByteString) <$> bld con--instance IsString SqlBuilder where- fromString s =- let b = fromString s :: ByteString- in toSqlBuilder b--instance ToSqlBuilder SqlBuilder where- toSqlBuilder = id-instance ToSqlBuilder Builder where- toSqlBuilder = sqlBuilderPure-instance ToSqlBuilder ByteString where- toSqlBuilder = sqlBuilderPure . BB.fromByteString-instance ToSqlBuilder BL.ByteString where- toSqlBuilder = sqlBuilderPure . BB.fromLazyByteString-instance ToSqlBuilder String where- toSqlBuilder = sqlBuilderPure . BB.fromString-instance ToSqlBuilder T.Text where- toSqlBuilder = sqlBuilderPure . BB.fromText-instance ToSqlBuilder TL.Text where- toSqlBuilder = sqlBuilderPure . BB.fromLazyText--{- | Shorthand function to convert identifier name to builder-->>> runSqlBuilder c $ mkIdent "simple\"ident"-"\"simple\"\"ident\""--Note correct string quoting made by __libpq__--}--mkIdent :: Text -> SqlBuilder-mkIdent t = sqlBuilderFromField "mkident a" $ Identifier t--{- | Shorthand function to convert single value to builder-->>> runSqlBuilder c $ mkValue "some ' value"-"'some '' value'"--Note correct string quoting--}--mkValue :: (ToField a) => a -> SqlBuilder-mkValue a = sqlBuilderFromField "mkValue a" a---- | Lift pure bytestring builder to 'SqlBuilder'-sqlBuilderPure :: Builder -> SqlBuilder-sqlBuilderPure b = SqlBuilder $ const $ pure b--sqlBuilderFromField :: (ToField a) => Query -> a -> SqlBuilder-sqlBuilderFromField q a =- SqlBuilder $ \c -> buildAction c q [] $ toField a -- FIXME: pass something as parameters string--instance Monoid SqlBuilder where- mempty = sqlBuilderPure mempty- mappend (SqlBuilder a) (SqlBuilder b) =- SqlBuilder $ \c -> mappend <$> (a c) <*> (b c)+import Database.PostgreSQL.Query.SqlBuilder.Builder+import Database.PostgreSQL.Query.SqlBuilder.Class+import Database.PostgreSQL.Query.SqlBuilder.Types
+ src/Database/PostgreSQL/Query/SqlBuilder/Builder.hs view
@@ -0,0 +1,90 @@+module Database.PostgreSQL.Query.SqlBuilder.Builder+ ( SqlBuilder(..)+ -- * Running+ , runSqlBuilder+ -- * Building+ , emptyB+ , mkValue+ , mkMaskedValue+ , sqlBuilderFromField+ -- ** Unsafe+ , sqlBuilderPure+ , sqlBuilderFromByteString+ ) where++import Blaze.ByteString.Builder (Builder)+import Data.ByteString (ByteString)+import Data.Semigroup+import Data.String+import Data.Typeable+import Database.PostgreSQL.Query.SqlBuilder.Types+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.ToField+import Database.PostgreSQL.Simple.Types+import GHC.Generics (Generic)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import qualified Blaze.ByteString.Builder as BB+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB+++-- | Builder wich can be effectively concatenated. Requires 'Connection'+-- inside for string quoting implemented in __libpq__. Builds two strings: query+-- string and log string which may differ.+newtype SqlBuilder = SqlBuilder+ { sqlBuild :: Connection -> LogMasker -> IO SqlBuilderResult+ } deriving (Typeable, Generic)++instance Semigroup SqlBuilder where+ (SqlBuilder a) <> (SqlBuilder b) =+ SqlBuilder $ \c masker -> (<>) <$> (a c masker) <*> (b c masker)++instance Monoid SqlBuilder where+ mempty = sqlBuilderPure mempty+ mappend = (<>)++instance IsString SqlBuilder where+ fromString s = SqlBuilder $ \_ _ -> return $ builderResultPure $ BB.fromString s++-- | Returns query string with log bytestring+runSqlBuilder :: Connection -> LogMasker -> SqlBuilder -> IO (Query, ByteString)+runSqlBuilder con masker (SqlBuilder bld) = toTuple <$> bld con masker+ where+ toTuple res =+ ( Query $ BB.toByteString $ sbQueryString res+ , BB.toByteString $ sbLogString res )++-- | Typed synonym of 'mempty'+emptyB :: SqlBuilder+emptyB = mempty++-- | Shorthand function to convert single field value to builder+mkValue :: (ToField a) => a -> SqlBuilder+mkValue = sqlBuilderFromField FieldDefault++-- | Shorthand function to convert single masked field value (which should not+-- be shown in log)+mkMaskedValue :: (ToField a) => a -> SqlBuilder+mkMaskedValue = sqlBuilderFromField FieldMasked++sqlBuilderFromField :: (ToField a) => FieldOption -> a -> SqlBuilder+sqlBuilderFromField fo field = SqlBuilder $ \con masker -> do+ qbs <- buildAction con "" [] $ toField field+ let sbQueryString = qbs+ sbLogString = masker fo qbs+ return SqlBuilderResult{..}++-- | Lift pure bytestring builder to 'SqlBuilder'. This is unsafe to use+-- directly in your code.+sqlBuilderPure :: Builder -> SqlBuilder+sqlBuilderPure b = SqlBuilder $ \_ _ -> pure $ builderResultPure b++-- | Unsafe function to make SqlBuilder from arbitrary ByteString. Does not+-- perform any checks. Dont use it directly in your code unless you know what+-- you are doing.+sqlBuilderFromByteString :: ByteString -> SqlBuilder+sqlBuilderFromByteString = sqlBuilderPure . BB.fromByteString
+ src/Database/PostgreSQL/Query/SqlBuilder/Class.hs view
@@ -0,0 +1,19 @@+module Database.PostgreSQL.Query.SqlBuilder.Class+ ( ToSqlBuilder(..)+ ) where++import Database.PostgreSQL.Query.SqlBuilder.Builder+import Database.PostgreSQL.Simple.Types++-- | Things which always can be transformed to 'SqlBuilder'+class ToSqlBuilder a where+ toSqlBuilder :: a -> SqlBuilder++instance ToSqlBuilder SqlBuilder where+ toSqlBuilder = id++instance ToSqlBuilder Identifier where+ toSqlBuilder ident = mkValue ident++instance ToSqlBuilder QualifiedIdentifier where+ toSqlBuilder qident = mkValue qident
+ src/Database/PostgreSQL/Query/SqlBuilder/Types.hs view
@@ -0,0 +1,64 @@+module Database.PostgreSQL.Query.SqlBuilder.Types+ ( -- * Sql builder result+ SqlBuilderResult(..)+ , builderResultPure+ -- * Field masking in logs+ , FieldOption(..)+ , LogMasker+ , defaultLogMasker+ , hugeFieldsMasker+ ) where+++import Blaze.ByteString.Builder (Builder)+import Data.Semigroup+import Data.String+import Data.Typeable+import GHC.Generics (Generic)+import Language.Haskell.TH.Lift++import qualified Blaze.ByteString.Builder as BB+import qualified Data.ByteString as BS++-- | Result if SqlBuilder. Contains separated builder for query and log.+data SqlBuilderResult = SqlBuilderResult+ { sbQueryString :: Builder+ , sbLogString :: Builder+ } deriving (Typeable, Generic)++instance Semigroup SqlBuilderResult where+ (SqlBuilderResult a b) <> (SqlBuilderResult a' b') =+ SqlBuilderResult (a <> a') (b <> b')++instance Monoid SqlBuilderResult where+ mempty = SqlBuilderResult mempty mempty+ mappend = (<>)++builderResultPure :: Builder -> SqlBuilderResult+builderResultPure b = SqlBuilderResult b b++-- | Option for field instructing 'LogMasker' what to do with field when logging+data FieldOption+ = FieldDefault+ -- ^ Do nothing. Field should be pasted as is+ | FieldMasked+ -- ^ Mask field in logs with placeholder.+ deriving (Eq, Ord, Show, Typeable, Generic)++deriveLift ''FieldOption++-- | Function modifying query parameter value before pasting it to log.+type LogMasker = FieldOption -> Builder -> Builder++-- | Simply replaces masked fields with placeholder.+defaultLogMasker :: LogMasker+defaultLogMasker FieldDefault bb = bb+defaultLogMasker FieldMasked _ = "'<MASKED BY POSTGRESQL-QUERY>'"++-- | Masks fields which size is bigger than given argument in bytes.+hugeFieldsMasker :: Int -> LogMasker+hugeFieldsMasker maxsize _ bb =+ let bl = BS.length $ BB.toByteString bb+ in if bl > maxsize+ then fromString $ "'<STRING SIZE: " ++ show bl ++ " MASKED BY POSTGRESQL-QUERY>'"+ else bb
src/Database/PostgreSQL/Query/TH.hs view
@@ -8,8 +8,6 @@ , module Database.PostgreSQL.Query.TH.SqlExp ) where -import Prelude- import Database.PostgreSQL.Query.TH.Entity import Database.PostgreSQL.Query.TH.Enum import Database.PostgreSQL.Query.TH.Row
src/Database/PostgreSQL/Query/TH/Entity.hs view
@@ -7,7 +7,7 @@ import Data.Default import Data.String-import Database.PostgreSQL.Query.Entity ( Entity(..) )+import Database.PostgreSQL.Query.Entity.Class import Database.PostgreSQL.Query.TH.Common import Database.PostgreSQL.Query.Types ( FN(..) ) import Database.PostgreSQL.Simple.FromField
src/Database/PostgreSQL/Query/TH/Enum.hs view
@@ -5,12 +5,15 @@ , InflectorFunc ) where -import Prelude- import Data.FileEmbed import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.ToField import Language.Haskell.TH++#if !MIN_VERSION_base(4,8,0)+import Data.Traversable+import Control.Applicative+#endif import qualified Data.Text.Encoding as T import qualified Data.Text as T
src/Database/PostgreSQL/Query/TH/Row.hs view
@@ -10,6 +10,9 @@ import Database.PostgreSQL.Simple.ToRow ( ToRow(..) ) import Language.Haskell.TH +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif {-| Derive 'FromRow' instance. i.e. you have type like that
src/Database/PostgreSQL/Query/TH/SqlExp.hs view
@@ -7,7 +7,6 @@ , ropeParser , parseRope , squashRope- , buildQ -- * Template haskell , sqlQExp , sqlExpEmbed@@ -25,9 +24,6 @@ import Data.Monoid import Data.Text ( Text ) import Database.PostgreSQL.Query.SqlBuilder- ( sqlBuilderFromField,- ToSqlBuilder(..) )-import Database.PostgreSQL.Simple.Types ( Query(..) ) import Language.Haskell.Meta.Parse.Careful import Language.Haskell.TH import Language.Haskell.TH.Quote@@ -77,11 +73,12 @@ -- | Internal type. Result of parsing sql string data Rope- = RLit Text -- ^ Part of raw sql- | RComment Text -- ^ Sql comment- | RSpaces Int -- ^ Sequence of spaces- | RInt Text -- ^ String with haskell expression inside __#{..}__- | RPaste Text -- ^ String with haskell expression inside __^{..}__+ = RLit Text -- ^ Part of raw sql+ | RComment Text -- ^ Sql comment+ | RSpaces Int -- ^ Sequence of spaces+ | RInt FieldOption Text -- ^ String with haskell expression inside __#{..}__+ -- or __#?{..}__+ | RPaste Text -- ^ String with haskell expression inside __^{..}__ deriving (Ord, Eq, Show) parseRope :: String -> [Rope]@@ -93,8 +90,9 @@ ropeParser = many1 $ choice [ quoted , iquoted- , ropeint- , ropepaste+ , RInt FieldMasked <$> someNested "#?{"+ , RInt FieldDefault <$> someNested "#{"+ , RPaste <$> someNested "^{" , comment , bcomment , spaces@@ -110,23 +108,17 @@ unquoteBraces = T.replace "\\}" "}" - ropeint = do- _ <- string "#{"- e <- many1 $ choice- [ string "\\}"- , T.singleton <$> notChar '}'- ]- _ <- char '}'- return $ RInt $ unquoteBraces $ mconcat e-- ropepaste = do- _ <- string "^{"+ -- Prefix must be string like '#{' or something+ someNested :: Text -> Parser Text+ someNested prefix = do+ _ <- string prefix e <- many1 $ choice [ string "\\}" , T.singleton <$> notChar '}' ]- _ <- char '}'- return $ RPaste $ unquoteBraces $ mconcat e+ eofErf ("block " <> T.unpack prefix <> " not finished") $ do+ _ <- char '}'+ return $ unquoteBraces $ mconcat e comment = do b <- string "--"@@ -177,33 +169,20 @@ -- | Build builder from rope-buildBuilder :: Exp -- ^ Expression of type 'Query'- -> Rope+buildBuilder :: Rope -> Maybe (Q Exp)-buildBuilder _ (RLit t) = Just $ do+buildBuilder (RLit t) = Just $ do bs <- bsToExp $ T.encodeUtf8 t- [e| toSqlBuilder $(pure bs) |]-buildBuilder q (RInt t) = Just $ do+ [e| sqlBuilderFromByteString $(pure bs) |]+buildBuilder (RInt fo t) = Just $ do when (T.null $ T.strip t) $ fail "empty interpolation string found" let ex = either error id $ parseExp $ T.unpack t- [e| sqlBuilderFromField $(pure q) $(pure ex) |]-buildBuilder _ (RPaste t) = Just $ do+ [e| sqlBuilderFromField $(lift fo) $(pure ex) |]+buildBuilder (RPaste t) = Just $ do when (T.null $ T.strip t) $ fail "empty paste string found" let ex = either error id $ parseExp $ T.unpack t [e| toSqlBuilder $(pure ex) |]-buildBuilder _ _ = Nothing---- | Build 'Query' expression from row-buildQ :: [Rope] -> Q Exp-buildQ r = do- bs <- bsToExp $ mconcat $ map fromRope r- [e| Query $(pure bs) |]- where- fromRope (RLit t) = T.encodeUtf8 t- fromRope (RInt t) = "#{" <> (T.encodeUtf8 t) <> "}"- fromRope (RPaste p) = "^{" <> (T.encodeUtf8 p) <> "}"- fromRope (RComment c) = T.encodeUtf8 c- fromRope (RSpaces _) = " "+buildBuilder _ = Nothing -- | Removes sequential occurencies of 'RLit' constructors. Also -- removes commentaries and squash sequences of spaces to single space@@ -223,12 +202,10 @@ sqlQExp :: String -> Q Exp -- ^ Expression of type 'SqlBuilder' sqlQExp s = do- let rope = squashRope- $ parseRope s- q <- buildQ rope+ let rope = squashRope $ parseRope s exps <- sequence $ catMaybes- $ map (buildBuilder q) rope+ $ map buildBuilder rope [e| ( mconcat $(pure $ ListE exps) ) |] {- | Embed sql template and perform interpolation
src/Database/PostgreSQL/Query/Types.hs view
@@ -1,11 +1,13 @@ module Database.PostgreSQL.Query.Types ( -- * Query execution HasPostgres(..)+ , MonadPostgres , TransactionSafe , PgMonadT(..) , runPgMonadT , launchPG -- * Auxiliary types+ , Qp(..) , InetText(..) , FN(..) , textFN@@ -14,8 +16,6 @@ , ToMarkedRow(..) ) where -import Prelude- import Control.Applicative import Control.Monad import Control.Monad.Base ( MonadBase(..) )@@ -38,29 +38,30 @@ import Control.Monad.Trans.Maybe import Control.Monad.Writer.Class ( MonadWriter ) import Data.HSet-import Data.Monoid import Data.Pool import Data.String import Data.Text ( Text ) import Data.Typeable import Database.PostgreSQL.Query.SqlBuilder- ( mkIdent, ToSqlBuilder(..), SqlBuilder(..) ) import Database.PostgreSQL.Query.TH.SqlExp- ( sqlExp ) import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.FromField- ( FromField(..), typename, returnError ) import Database.PostgreSQL.Simple.ToField- ( ToField )+import Database.PostgreSQL.Simple.Types import GHC.Generics import Instances.TH.Lift () import Language.Haskell.TH.Lift ( deriveLift ) -import qualified Data.List as L+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif++import qualified Blaze.ByteString.Builder.ByteString as BB import qualified Control.Monad.Trans.State.Lazy as STL import qualified Control.Monad.Trans.State.Strict as STS import qualified Control.Monad.Trans.Writer.Lazy as WL import qualified Control.Monad.Trans.Writer.Strict as WS+import qualified Data.List as L import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -71,6 +72,13 @@ -} +-- | Special constructor to perform old-style query interpolation+data Qp = forall row. (ToRow row) => Qp Query row++instance ToSqlBuilder Qp where+ toSqlBuilder (Qp q row) = SqlBuilder $ \con _ ->+ builderResultPure . BB.fromByteString <$> formatQuery con q row+ -- | type to put and get from db 'inet' and 'cidr' typed postgresql -- fields. This should be in postgresql-simple in fact. newtype InetText = InetText@@ -131,7 +139,7 @@ toSqlBuilder (FN tt) = mconcat $ L.intersperse "."- $ map mkIdent tt+ $ map (toSqlBuilder . Identifier) tt instance IsString FN where fromString s =@@ -200,6 +208,7 @@ where tobld (f, val) = [sqlExp| ^{f} = ^{val} |] +type MonadPostgres m = (HasPostgres m, MonadLogger m) -- | Instances of this typeclass can acquire connection and pass it to -- computation. It can be reader of pool of connections or just reader of
+ test/BuilderTest.hs view
@@ -0,0 +1,33 @@+module BuilderTest+ ( builderTests+ ) where++import Data.Text (Text)+import Database.PostgreSQL.Query+import Database.PostgreSQL.Simple+import Test.Tasty+import Test.Tasty.HUnit++caseLogDefault :: IO Connection -> TestTree+caseLogDefault iocon = testCase "expect parameter pasted" $ do+ con <- iocon+ let t = "TEXT" :: Text+ (q, l) <- runSqlBuilder con defaultLogMasker [sqlExp|INSERT #{t}|]+ q @?= "INSERT 'TEXT'"+ l @?= "INSERT 'TEXT'"++caseLogMask :: IO Connection -> TestTree+caseLogMask iocon = testCase "exptect parameter masked" $ do+ con <- iocon+ let t = "TEXT" :: Text+ (q, l) <- runSqlBuilder con defaultLogMasker [sqlExp|INSERT #?{t}|]+ q @?= "INSERT 'TEXT'"+ l @?= "INSERT '<MASKED BY POSTGRESQL-QUERY>'"+++builderTests :: TestTree+builderTests =+ withResource (connectPostgreSQL "") close $ \con -> testGroup "BuilderTest"+ [ caseLogMask con+ , caseLogDefault con+ ]
test/Main.hs view
@@ -1,125 +1,10 @@-{-# OPTIONS -fno-warn-orphans #-}- module Main where -import Control.Applicative-import Data.Attoparsec.Text ( parseOnly )-import Data.Monoid-import Data.Text ( Text )-import Database.PostgreSQL.Query.TH.SqlExp-import Test.QuickCheck.Assertions-import Test.QuickCheck.Instances ()-import Test.QuickCheck.Modifiers-import Test.QuickCheck.Property- ( Result )+import BuilderTest+import ParserTest import Test.Tasty-import Test.Tasty.QuickCheck-import Test.Tasty.TH -import qualified Data.Text as T--noSeqSpace :: [Rope] -> [Rope]-noSeqSpace ((RSpaces a):(RSpaces b):xs) = noSeqSpace- $ (RSpaces $ a + b):xs-noSeqSpace (x:xs) = x:(noSeqSpace xs)-noSeqSpace [] = []--newtype RopeList- = RopeList [Rope]- deriving (Ord, Eq, Show)--instance Arbitrary RopeList where- arbitrary =- resize 10 $ (RopeList . noSeqSpace . getNonEmpty) <$> arbitrary--wordAlpha :: [Text]-wordAlpha = map T.singleton- $ ['A'..'Z'] ++ ['a'..'z']- ++ "!@$%&*()[];|{}<>="--stringAlpha :: [Text]-stringAlpha = wordAlpha ++ ["''", "\\'", " "]--identAlpha :: [Text]-identAlpha = wordAlpha ++ ["\"\"", " "]--intAlpha :: [Text]-intAlpha = wordAlpha ++ [" "]--instance Arbitrary Rope where- arbitrary =- oneof [ RLit <$> stringLit- , RLit <$> idLit- , RInt <$> ropeInt- , RPaste <$> ropePaste- , RComment <$> comment- , RComment <$> bcomment- , RSpaces <$> spaces- , RLit <$> wordLit- ]- where- selems = resize 5 . listOf . elements- selems1 = resize 5 . listOf1 . elements- stringLit = do- x <- selems stringAlpha- return $ "'" <> mconcat x <> "'"-- idLit = do- x <- selems identAlpha- return $ "\"" <> mconcat x <> "\""- ropeInt = do- x <- selems intAlpha- return $ "#{" <> mconcat x <> "}"- ropePaste = do- x <- selems1 intAlpha- return $ "^{" <> mconcat x <> "}"- comment = do- s <- selems wordAlpha- return $ "--" <> mconcat s- bcomment = do- n <- selems wordAlpha- return $ "/*" <> mconcat n <> "*/"- spaces = suchThat arbitrary (>= 1)- wordLit = fmap mconcat- $ selems1 wordAlpha---flattenRope :: [Rope] -> Text-flattenRope = mconcat . map f- where- f (RLit t) = t- f (RComment c) = case T.uncons c of- (Just ('-', _)) -> c <> "\n"- _ -> c- f (RSpaces s) = mconcat $ replicate s " "- f (RInt t) = "#{" <> quoteBrace t <> "}"- f (RPaste t) = "^{" <> quoteBrace t <> "}"- quoteBrace = T.replace "}" "\\}"--prop_RopeParser :: RopeList -> Result-prop_RopeParser (RopeList rope) =- (Right $ squashRope rope) ==?- (fmap squashRope $ parseOnly ropeParser $ flattenRope rope)---- case_cleanLit :: Assertion--- case_cleanLit =--- mapM_ (\(a, b) -> a @=? (cleanLit b))--- [ ("hello hello", "hello hello")--- , ("'hello hello '", "'hello hello '")--- , (" SELECT ", " SELECT -- ")--- , ("xxx ' '' '", "xxx ' '' '")--- , ("xxx xxx xxx", "xxx xxx -- \n xxx")--- , (" ' ''\\'' ", " ' ''\\'' ")--- , ("'''\\'''''\\'' ", "'''\\'''''\\'' ")--- , (" \" ident \" ", " \" ident \" ")--- , (" one - two -> plus ", " one - \n two -> plus -- \n")--- , ("xxx ", "xxx /* thus must eliminate */")--- , ("xxx xxx", "xxx /* bla /* nested */ \n comment */ xxx")--- ]--mainGroup :: TestTree-mainGroup = $testGroupGenerator- main :: IO ()-main = do- defaultMain mainGroup+main = defaultMain $ testGroup "main"+ [ parserTests+ , builderTests ]
+ test/ParserTest.hs view
@@ -0,0 +1,178 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ParserTest+ ( parserTests+ ) where++import Data.Attoparsec.Text ( parseOnly )+import Data.Derive.Arbitrary+import Data.DeriveTH+import Data.Monoid+import Data.Text ( Text )+import Database.PostgreSQL.Query.SqlBuilder+import Database.PostgreSQL.Query.TH.SqlExp+import Test.QuickCheck.Assertions+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Modifiers+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.Tasty.TH++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import qualified Data.Text as T++noSeqSpace :: [Rope] -> [Rope]+noSeqSpace ((RSpaces a):(RSpaces b):xs) = noSeqSpace+ $ (RSpaces $ a + b):xs+noSeqSpace (x:xs) = x:(noSeqSpace xs)+noSeqSpace [] = []++newtype RopeList = RopeList [Rope]+ deriving (Ord, Eq, Show)++instance Arbitrary RopeList where+ arbitrary = resize 10 $ (RopeList . noSeqSpace . getNonEmpty) <$> arbitrary++wordAlpha :: [Text]+wordAlpha = map T.singleton+ $ ['A'..'Z'] ++ ['a'..'z']+ ++ "!@$%&*()[];|{}<>="++stringAlpha :: [Text]+stringAlpha = wordAlpha ++ ["''", "\\'", " "]++identAlpha :: [Text]+identAlpha = wordAlpha ++ ["\"\"", " "]++intAlpha :: [Text]+intAlpha = wordAlpha ++ [" "]++derive makeArbitrary ''FieldOption++instance Arbitrary Rope where+ arbitrary =+ oneof [ RLit <$> stringLit+ , RLit <$> idLit+ , RInt <$> arbitrary <*> ropeInt+ , RPaste <$> ropePaste+ , RComment <$> comment+ , RComment <$> bcomment+ , RSpaces <$> spaces+ , RLit <$> wordLit+ ]+ where+ selems = resize 5 . listOf . elements+ selems1 = resize 5 . listOf1 . elements+ stringLit = do+ x <- selems stringAlpha+ return $ "'" <> mconcat x <> "'"+ idLit = do+ x <- selems identAlpha+ return $ "\"" <> mconcat x <> "\""+ ropeInt = do+ x <- selems intAlpha+ return $ "#{" <> mconcat x <> "}"+ ropePaste = do+ x <- selems1 intAlpha+ return $ "^{" <> mconcat x <> "}"+ comment = do+ s <- selems wordAlpha+ return $ "--" <> mconcat s+ bcomment = do+ n <- selems wordAlpha+ return $ "/*" <> mconcat n <> "*/"+ spaces = suchThat arbitrary (>= 1)+ wordLit = fmap mconcat+ $ selems1 wordAlpha++flattenRope :: [Rope] -> Text+flattenRope = mconcat . map f+ where+ f (RLit t) = t+ f (RComment c) = case T.uncons c of+ (Just ('-', _)) -> c <> "\n"+ _ -> c+ f (RSpaces s) = mconcat $ replicate s " "+ f (RInt FieldDefault t) = "#{" <> quoteBrace t <> "}"+ f (RInt FieldMasked t) = "#?{" <> quoteBrace t <> "}"+ f (RPaste t) = "^{" <> quoteBrace t <> "}"+ quoteBrace = T.replace "}" "\\}"++prop_RopeParser :: RopeList -> Result+prop_RopeParser (RopeList rope) =+ (Right $ squashRope rope) ==?+ (fmap squashRope $ parseOnly ropeParser $ flattenRope rope)++expectParser :: (Eq a, Show a) => ([Rope] -> a) -> (a, Text) -> Assertion+expectParser predicate (a, raw) = do+ rope <- either fail return $ parseOnly ropeParser raw+ a @=? predicate rope++case_expectLiterals :: Assertion+case_expectLiterals = mapM_ (expectParser takeLits)+ [ ("hello hello", "hello hello")+ , ("'hello hello '", "'hello hello '")+ , (" SELECT ", " SELECT -- ")+ , ("xxx ' '' '", "xxx ' '' '")+ , ("xxx xxx xxx", "xxx xxx -- \n xxx")+ , (" ' ''\\'' ", " ' ''\\'' ")+ , ("'''\\'''''\\'' ", "'''\\'''''\\'' ")+ , (" \" ident \" ", " \" ident \" ")+ , (" one - two -> plus ", " one - \n two -> plus -- \n")+ , ("xxx ", "xxx /* this must eliminate */")+ , ("xxx xxx", "xxx /* bla /* nested */ \n comment */ xxx")+ ]+ where+ takeLits = mconcat . map takeLit+ takeLit :: Rope -> Text+ takeLit (RLit t) = t+ takeLit (RSpaces _) = " "+ takeLit _ = ""++case_expectComments :: Assertion+case_expectComments = mapM_ (expectParser takeComments)+ [ ("", "hello hello")+ , ("", "'hello hello '")+ , ("-- line comment", " SELECT -- line comment")+ , ("/* comment */", "/* comment */ ' /* */ '' -- '")+ ]+ where+ takeComments = mconcat . map takeComment+ takeComment :: Rope -> Text+ takeComment (RComment t) = t+ takeComment _ = ""++case_expectInterpolation :: Assertion+case_expectInterpolation = mapM_ (expectParser takeInterpol)+ [ ("", " hello hello ")+ , ("something", " hello #{something} happend")+ , ("something", " hello ^{something} happend")+ , ("something", " hello #?{something} happend")+ , ("", " 'hello #{something} happend' ")+ , ("", " 'hello ^{something} happend' ")+ , ("", " 'hello #?{something} happend' ")+ , ("", " \"hello #{something} happend\" ")+ , ("", " \"hello ^{something} happend\" ")+ , ("", " \"hello #?{something} happend\" ")+ , ("", " -- hello #{something} happend ")+ , ("", " -- hello ^{something} happend' ")+ , ("", " -- hello #?{something} happend' ")+ , ("", " /* hello #{something} happend */ ")+ , ("", " /* hello ^{something} happend */ ")+ , ("", " /* hello #?{something} happend */ ")++ ]+ where+ takeInterpol = mconcat . map go+ go :: Rope -> Text+ go (RInt _ t) = t+ go (RPaste t) = t+ go _ = ""+++parserTests :: TestTree+parserTests = $testGroupGenerator