postgresql-query (empty) → 1.0.0
raw patch · 13 files changed
+2005/−0 lines, 13 filesdep +QuickCheckdep +aesondep +attoparsecsetup-changed
Dependencies added: QuickCheck, aeson, attoparsec, base, blaze-builder, bytestring, containers, either, exceptions, file-embed, haskell-src-meta, monad-control, monad-logger, mtl, postgresql-query, postgresql-simple, quickcheck-assertions, quickcheck-instances, resource-pool, semigroups, tasty, tasty-hunit, tasty-quickcheck, tasty-th, template-haskell, text, time, transformers, transformers-base, transformers-compat
Files
- LICENSE +30/−0
- README.md +134/−0
- Setup.hs +2/−0
- postgresql-query.cabal +104/−0
- src/Database/PostgreSQL/Query.hs +41/−0
- src/Database/PostgreSQL/Query/Entity.hs +26/−0
- src/Database/PostgreSQL/Query/Functions.hs +370/−0
- src/Database/PostgreSQL/Query/Internal.hs +275/−0
- src/Database/PostgreSQL/Query/SqlBuilder.hs +132/−0
- src/Database/PostgreSQL/Query/TH.hs +130/−0
- src/Database/PostgreSQL/Query/TH/SqlExp.hs +267/−0
- src/Database/PostgreSQL/Query/Types.hs +369/−0
- test/Main.hs +125/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Aleksey Uimanov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Aleksey Uimanov nor the names of other+ 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 ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,134 @@+# What ?++`postgresql-query` is a library for more simple query generation for+PostgreSQL database. It is not an ORM (but contains some part of). It+contains interpolating quasiquote for simple query generation.++# Motivation++When you want to perform some complex SQL query using+`postgresql-simple` you writing this query by hands like that:++```haskell+let q = mconcat+ [ "SELECT u.id, u.name, count(p.id) "+ , "FROM users as u INNER JOIN posts as p "+ , "ON u.id = p.user_id "+ , "WHERE u.name like ? AND u.created BETWEEN ? AND ? "+ , "GROUP BY u.id ORDER BY ? " ]+```++Well, this is not realy complex. Now what you need to perform the+query is to paste parameters instead of this `?` signs:++```haskell+query con q ("%Peyton%", now, yesterday)+```++Did you see the mistake? We forgot about ordering field. To perform this query we must++```haskell+query con q ("%Peyton%", now, yesterday, Identifier "...+```++Oups!. If we use `Identifier "u.name"` we will get `"u.name"` in our+query which is just not right. Sql syntax assumes `"u"."name"` for+this query. We can not use query parameter to paste optional field+here.+++Next example is more complex:++```haskell+let name = Just "%Peyton%" -- assume we getting parameters from query+ minage = Just 10+ maxage = Just 50+ condlist = catMaybes+ [ const " u.name like ? " <$> name+ , const " u.age > ? " <$> minage+ , const " u.age < ? " <$> maxage ]+ paramlist = catMaybes+ [ toField <$> name+ , toField <$> minage+ , toField <$> maxage ]+ cond = if L.null condlist+ then mempty+ else "WHERE " <> (mconcat $ L.intersperse " AND " condlist)+ q = "SELECT u.id, u.name, u.age FROM users AS u " <> cond+query con q paramlist+```++So much to write and so many chances to make a mistake. What if we+could write this like:++```haskell+let name = Just "%Peyton%" -- assume we getting parameters from query+ minage = Just 10+ maxage = Just 50+ ord = "u.name" :: FN -- <- special type for field names!+ condlist = catMaybes+ [ (\a -> [sqlExp|u.name like #{a}|]) <$> name+ , (\a -> [sqlExp|u.age > #{a}|]) <$> minage+ , (\a -> [sqlExp|u.age < #{a}|]) <$> maxage ]+ cond = if L.null condlist+ then mempty+ else [sqlExp|WHERE ^{mconcat $ L.intersperse " AND " condlist}|]+pqQuery [sqlExp|SELECT u.id, u.name, u.age+ FROM users AS u ^{cond}+ ORDER BY ^{ord}|]+```++Much better!++# sqlExp++Quasiquote `sqlExp` has two way of interpolation:++* `#{exp}` - pastes inside query arbitrary value which type is+ instance of `ToField` typeclass. It performs correct strings+ escaping so it is not the same as stupid string interpolation. Dont+ worry about sql-injections when using it.++* `^{exp}` - pastes inside query arbitrary value which type has+ instance of `ToSqlBuilder` typeclass.++`sqlExp` returns `SqlBuilder` which has a `Monoid` instance+and made for effective concatination (bytestring builder works+inside).++This quasiquote correctly handles string literals and quoted+identifiers. It also removes line and block (even nested) sql comments+from resulting query as well as sequences of space characters. You are+free to write queries like++```sql+WHERE name SIMILAR TO '\^{2,3}' -- line comment #{ololo}+```++or even++```sql+WHERE "#{strange}identifier" SIMILAR TO '#{1,10}' /*nested/*^{block}*/comment*/+```++`sqlExp` will remove all comments and will not interpolate inside+string literals or quoted identifiers at all.++## sqlExpEmbed and sqlExpFile++If you have realy huge hardcore sql template you can++```haskell+pgQuery $(sqlExpEmbed "sql/foo/bar.sql")+```++It works just like Yesod's templates. You can use interpolation inside+templates like inside `sqlExp`.++```haskell+pgQuery $(sqlExpFile "foo/bar")+```++Is absolutely the same as above. It just prepends `sql/` and+appends `.sql` to your string. If you agree to follow naming+conventions you are welcome to use `sqlExpFile`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ postgresql-query.cabal view
@@ -0,0 +1,104 @@+name: postgresql-query+version: 1.0.0++synopsis: Sql interpolating quasiquote plus some kind of primitive ORM+ using it++license: BSD3+license-file: LICENSE+author: Aleksey Uimanov+maintainer: s9gf4ult@gmail.com+-- copyright:+category: Database+build-type: Simple++extra-source-files: README.md++cabal-version: >=1.10++library+ hs-source-dirs: src++ exposed-modules: Database.PostgreSQL.Query+ , Database.PostgreSQL.Query.Entity+ , Database.PostgreSQL.Query.Functions+ , Database.PostgreSQL.Query.Internal+ , Database.PostgreSQL.Query.SqlBuilder+ , Database.PostgreSQL.Query.TH+ , Database.PostgreSQL.Query.TH.SqlExp+ , Database.PostgreSQL.Query.Types++ default-extensions: TemplateHaskell+ , CPP+ , DeriveDataTypeable+ , DeriveGeneric+ , EmptyDataDecls+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , NoImplicitPrelude+ , NoMonomorphismRestriction+ , OverloadedStrings+ , QuasiQuotes+ , RecordWildCards+ , ScopedTypeVariables+ , StandaloneDeriving+ , TupleSections+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+ , ViewPatterns++ build-depends: base >=4.6 && < 5+ , aeson+ , attoparsec+ , blaze-builder+ , bytestring+ , containers+ , either+ , exceptions+ , file-embed+ , haskell-src-meta+ , monad-control == 0.3.3.1 || > 1.0.0.3+ , monad-logger+ , mtl+ , postgresql-simple >= 0.4.10.0+ , resource-pool+ , semigroups+ , template-haskell+ , text+ , time+ , transformers < 0.4+ , transformers-base+ , transformers-compat >= 0.3++ ghc-options: -Wall++ default-language: Haskell2010+++test-suite test+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: test+ main-is: Main.hs++ default-extensions: OverloadedStrings+ , TemplateHaskell+ , FlexibleInstances++ build-depends: base >=4.6 && < 5+ , QuickCheck+ , attoparsec+ , postgresql-query+ , quickcheck-assertions+ , quickcheck-instances+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , tasty-th+ , text
+ src/Database/PostgreSQL/Query.hs view
@@ -0,0 +1,41 @@+module Database.PostgreSQL.Query+ ( -- * Common usage modules+ module Database.PostgreSQL.Query.Entity+ , module Database.PostgreSQL.Query.Functions+ , module Database.PostgreSQL.Query.SqlBuilder+ , module Database.PostgreSQL.Query.TH+ , module Database.PostgreSQL.Query.Types++ -- * Some re-exports from postgresql-simple+ , Connection, connect, defaultConnectInfo, connectPostgreSQL+ , ConnectInfo(..) , ToField(..), ToRow(..), FromField(..)+ , FromRow(..), Query(..), Only(..), In(..), Oid(..), Values(..)+ , (:.)(..), PGArray(..), HStoreList(..), HStoreMap(..)+ , ToHStore(..), HStoreBuilder , hstore, parseHStoreList+ , ToHStoreText(..), HStoreText , sqlQQ+ ) where+++import Database.PostgreSQL.Simple+ ( ToRow, Connection, FromRow, defaultConnectInfo,+ connectPostgreSQL, connect, ConnectInfo(..) )+import Database.PostgreSQL.Simple.FromField ( FromField(..) )+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
@@ -0,0 +1,26 @@+module Database.PostgreSQL.Query.Entity+ ( Entity(..)+ , Ent+ ) where++import Data.Proxy+import Data.Text ( Text )+import Data.Typeable+ ( Typeable )++-- | 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 -> Text+ -- | 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 -> [Text]++deriving instance Typeable EntityId++-- | Entity with it's id+type Ent a = (EntityId a, a)
+ src/Database/PostgreSQL/Query/Functions.hs view
@@ -0,0 +1,370 @@+module Database.PostgreSQL.Query.Functions+ ( -- * Raw query execution+ pgQuery+ , pgExecute+ , pgQueryEntities+ -- * Transactions+ , pgWithTransaction+ , pgWithSavepoint+ -- * Work with entities+ , pgInsertEntity+ , pgInsertManyEntities+ , pgInsertManyEntitiesId+ , pgSelectEntities+ , pgSelectJustEntities+ , pgSelectEntitiesBy+ , pgGetEntity+ , pgGetEntityBy+ , pgDeleteEntity+ , pgUpdateEntity+ , pgSelectCount+ -- * Auxiliary functions+ , 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.Text ( Text )+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, mkIdent )+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_,+ withTransaction, withSavepoint )+import Database.PostgreSQL.Simple.FromField+ ( FromField )+import Database.PostgreSQL.Simple.ToField+ ( ToField )+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 all queries inside one transaction. Rollback transaction on exceptions+pgWithTransaction :: (HasPostgres m, MonadBaseControl IO m, TransactionSafe m)+ => m a+ -> m a+pgWithTransaction action = withPGConnection $ \con -> do+ control $ \runInIO -> do+ withTransaction con $ runInIO action++-- | Same as `pgWithTransaction` but executes queries inside savepoint+pgWithSavepoint :: (HasPostgres m, MonadBaseControl IO m, TransactionSafe m) => m a -> m a+pgWithSavepoint action = withPGConnection $ \con -> do+ control $ \runInIO -> do+ withSavepoint con $ runInIO action++{- | 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 ()+pgInsertManyEntities [] = return ()+pgInsertManyEntities ents' =+ let ents = NL.fromList ents'+ in void $ pgExecute $ insertManyEntities ents+++{- | Delete entity.++@+rmUser :: EntityId User -> Handler ()+rmUser uid = do+ pgDeleteEntity uid+@++-}++pgDeleteEntity :: forall a m. (Entity a, HasPostgres m, MonadLogger m, ToField (EntityId a), Functor m)+ => EntityId a+ -> m ()+pgDeleteEntity eid =+ let p = Proxy :: Proxy a+ in (const ()) <$> pgExecute [sqlExp|DELETE FROM ^{mkIdent $ 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)]+@++-}++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 ()+pgUpdateEntity eid b =+ let p = Proxy :: Proxy a+ mr = toMarkedRow b+ in if L.null $ unMR mr+ then return ()+ else fmap (const ())+ $ pgExecute [sqlExp|UPDATE ^{mkIdent $ 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 ^{mkIdent $ 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++@+pgRepsertRow "emails" (MR [("user_id", mkValue uid)]) (MR [("email", mkValue email)])+@++Then firstly will be performed++@+UPDATE "emails" SET email = 'foo@bar.com' WHERE "user_id" = 1234+@++And if no one row is affected (which is returned by 'pgExecute'), then++@+INSERT INTO "emails" ("user_id", "email") VALUES (1234, 'foo@bar.com')+@++will be performed++-}++pgRepsertRow :: (HasPostgres m, MonadLogger m, ToMarkedRow wrow, ToMarkedRow urow)+ => Text -- ^ Table name+ -> wrow -- ^ where condition+ -> urow -- ^ update row+ -> m ()+pgRepsertRow tname wrow urow = do+ let wmr = toMarkedRow wrow+ aff <- pgExecute $ updateTable tname urow+ [sqlExp|WHERE ^{mrToBuilder "AND" wmr}|]+ when (aff == 0) $ do+ let umr = toMarkedRow urow+ imr = wmr <> umr+ _ <- pgExecute $ insertInto tname imr+ return ()
+ src/Database/PostgreSQL/Query/Internal.hs view
@@ -0,0 +1,275 @@+module Database.PostgreSQL.Query.Internal+ ( -- * Entity functions+ entityFields+ , entityFieldsId+ , selectEntity+ , selectEntitiesBy+ , insertEntity+ , insertManyEntities+ , entityToMR+ -- * Low level generators+ , buildFields+ , updateTable+ , insertInto+ ) where+++import Prelude++import Data.List.NonEmpty ( NonEmpty )+import Data.Monoid+import Data.Proxy ( Proxy(..) )+import Data.Text ( Text )+import Database.PostgreSQL.Query.Entity+ ( Entity(..) )+import Database.PostgreSQL.Query.SqlBuilder+ ( SqlBuilder, ToSqlBuilder(..),+ mkIdent, mkValue )+import Database.PostgreSQL.Query.TH+ ( sqlExp )+import Database.PostgreSQL.Query.Types+ ( FN(..), textFN, MarkedRow(..),+ ToMarkedRow(..), mrToBuilder )+import Database.PostgreSQL.Simple.ToRow+ ( ToRow(..) )++import qualified Data.List.NonEmpty as NL+import qualified Data.List as L++{- $setup+>>> import Database.PostgreSQL.Simple+>>> import Database.PostgreSQL.Simple.ToField+>>> import PGSimple.SqlBuilder+>>> con <- connect defaultConnectInfo+-}+++{-| Generates comma separated list of field names++>>> runSqlBuilder con $ buildFields ["u" <> "name", "u" <> "phone", "e" <> "email"]+"\"u\".\"name\", \"u\".\"phone\", \"e\".\"email\""+-}+buildFields :: [FN] -> SqlBuilder+buildFields flds = mconcat+ $ L.intersperse ", "+ $ map toSqlBuilder flds++{- | generates __UPDATE__ query++>>> let name = "%vip%"+>>> runSqlBuilder con $ updateTable "ships" (MR [("size", mkValue 15)]) [sqlExp|WHERE size > 15 AND name NOT LIKE #{name}|]+"UPDATE \"ships\" SET \"size\" = 15 WHERE size > 15 AND name NOT LIKE '%vip%'"++-}++updateTable :: (ToSqlBuilder q, ToMarkedRow flds)+ => Text -- ^ table name+ -> flds -- ^ fields to update+ -> q -- ^ condition+ -> SqlBuilder+updateTable tname flds q =+ let mr = toMarkedRow flds+ setFields = mrToBuilder ", " mr+ in [sqlExp|UPDATE ^{mkIdent tname}+ SET ^{setFields} ^{q}|]+++{- | Generate INSERT INTO query for entity++>>> runSqlBuilder con $ insertInto "foo" $ MR [("name", mkValue "vovka"), ("hobby", mkValue "president")]+"INSERT INTO \"foo\" (\"name\", \"hobby\") VALUES ('vovka', 'president')"++-}++insertInto :: (ToMarkedRow b)+ => Text -- ^ table name+ -> b -- ^ list of pairs (name, value) to insert into+ -> SqlBuilder+insertInto tname b =+ let mr = toMarkedRow b+ names = mconcat+ $ L.intersperse ", "+ $ map (toSqlBuilder . fst)+ $ unMR mr+ values = mconcat+ $ L.intersperse ", "+ $ map snd+ $ unMR mr+ in [sqlExp|INSERT INTO ^{mkIdent 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 . FN . (:[]))+ $ 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 ^{mkIdent $ 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 = map textFN $ 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 mkIdent+ $ fieldNames p+ values = mconcat+ $ L.intersperse ","+ $ map rValue+ $ NL.toList rows++ in [sqlExp|INSERT INTO ^{mkIdent $ tableName p}+ (^{names}) VALUES ^{values}|]+ where+ rValue row =+ let values = mconcat+ $ L.intersperse ","+ $ map mkValue+ $ toRow row+ in [sqlExp|(^{values})|]
+ src/Database/PostgreSQL/Query/SqlBuilder.hs view
@@ -0,0 +1,132 @@+module Database.PostgreSQL.Query.SqlBuilder+ ( -- * Types+ SqlBuilder(..)+ , ToSqlBuilder(..)+ , Qp(..)+ -- * SqlBuilder helpers+ , emptyB+ , runSqlBuilder+ , mkIdent+ , mkValue+ , sqlBuilderPure+ , sqlBuilderFromField+ ) 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)
+ src/Database/PostgreSQL/Query/TH.hs view
@@ -0,0 +1,130 @@+module Database.PostgreSQL.Query.TH+ ( -- * Deriving instances+ deriveFromRow+ , deriveToRow+ -- * Embedding sql files+ , embedSql+ , sqlFile+ -- * Sql string interpolation+ , sqlExp+ , sqlExpEmbed+ , sqlExpFile+ ) where++import Prelude++import Control.Applicative+import Data.FileEmbed ( embedFile )+import Database.PostgreSQL.Simple.FromRow ( FromRow(..), field )+import Database.PostgreSQL.Simple.ToRow ( ToRow(..) )+import Database.PostgreSQL.Simple.Types ( Query(..) )+import Language.Haskell.TH+import Database.PostgreSQL.Query.TH.SqlExp+++cName :: (Monad m) => Con -> m Name+cName (NormalC n _) = return n+cName (RecC n _) = return n+cName _ = error "Constructor must be simple"++cArgs :: (Monad m) => Con -> m Int+cArgs (NormalC _ n) = return $ length n+cArgs (RecC _ n) = return $ length n+cArgs _ = error "Constructor must be simple"++-- | Derive 'FromRow' instance. i.e. you have type like that+--+-- @+-- data Entity = Entity+-- { eField :: Text+-- , eField2 :: Int+-- , efield3 :: Bool }+-- @+--+-- then 'deriveFromRow' will generate this instance:+-- instance FromRow Entity where+--+-- @+-- instance FromRow Entity where+-- fromRow = Entity+-- \<$> field+-- \<*> field+-- \<*> field+-- @+--+-- Datatype must have just one constructor with arbitrary count of fields+deriveFromRow :: Name -> Q [Dec]+deriveFromRow t = do+ TyConI (DataD _ _ _ [con] _) <- reify t+ cname <- cName con+ cargs <- cArgs con+ [d|instance FromRow $(return $ ConT t) where+ fromRow = $(fieldsQ cname cargs)|]+ where+ fieldsQ cname cargs = do+ fld <- [| field |]+ fmp <- [| (<$>) |]+ fap <- [| (<*>) |]+ return $ UInfixE (ConE cname) fmp (fapChain cargs fld fap)++ fapChain 0 _ _ = error "there must be at least 1 field in constructor"+ fapChain 1 fld _ = fld+ fapChain n fld fap = UInfixE fld fap (fapChain (n-1) fld fap)++lookupVNameErr :: String -> Q Name+lookupVNameErr name =+ lookupValueName name >>=+ maybe (error $ "could not find identifier: " ++ name)+ return+++-- | derives 'ToRow' instance for datatype like+--+-- @+-- data Entity = Entity+-- { eField :: Text+-- , eField2 :: Int+-- , efield3 :: Bool }+-- @+--+-- it will derive instance like that:+--+-- @+-- instance ToRow Entity where+-- toRow (Entity e1 e2 e3) =+-- [ toField e1+-- , toField e2+-- , toField e3 ]+-- @+deriveToRow :: Name -> Q [Dec]+deriveToRow t = do+ TyConI (DataD _ _ _ [con] _) <- reify t+ cname <- cName con+ cargs <- cArgs con+ cvars <- sequence+ $ replicate cargs+ $ newName "a"+ [d|instance ToRow $(return $ ConT t) where+ toRow $(return $ ConP cname $ map VarP cvars) = $(toFields cvars)|]+ where+ toFields v = do+ tof <- lookupVNameErr "toField"+ return $ ListE+ $ map+ (\e -> AppE (VarE tof) (VarE e))+ v++-- embed sql file as value+embedSql :: String -- ^ File path+ -> Q Exp+embedSql path = do+ [e| (Query ( $(embedFile path) )) |]+{-# DEPRECATED embedSql "use 'sqlExpEmbed' instead" #-}++-- embed sql file by pattern. __sqlFile "dir/file"__ is just the same as+-- __embedSql "sql/dir/file.sql"__+sqlFile :: String -- ^ sql file pattern+ -> Q Exp+sqlFile s = do+ embedSql $ "sql/" ++ s ++ ".sql"+{-# DEPRECATED sqlFile "use 'sqlExpFile' instead" #-}
+ src/Database/PostgreSQL/Query/TH/SqlExp.hs view
@@ -0,0 +1,267 @@+module Database.PostgreSQL.Query.TH.SqlExp+ ( -- * QQ+ sqlExp+ -- * Types+ , Rope(..)+ -- * Parser+ , ropeParser+ , parseRope+ , squashRope+ , buildQ+ -- * Template haskell+ , sqlQExp+ , sqlExpEmbed+ , sqlExpFile+ ) where+import Prelude hiding (takeWhile)++import Control.Applicative+import Control.Monad ( when )+import Data.Attoparsec.Combinator+import Data.Attoparsec.Text+import Data.Char ( isSpace )+import Data.FileEmbed ( bsToExp )+import Data.Maybe+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+import Language.Haskell.TH.Syntax++import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++{- $setup+>>> import Database.PostgreSQL.Simple+>>> import PGSimple.SqlBuilder+>>> import qualified Data.List as L+>>> c <- connect defaultConnectInfo+-}++{- | Maybe the main feature of all library. Quasiquoter which builds+'SqlBuilder' from string query. Removes line comments and block+comments (even nested) and sequences of spaces. Correctly works+handles string literals and quoted identifiers. Here is examples of usage++>>> let name = "name"+>>> let val = "some 'value'"+>>> runSqlBuilder c [sqlExp|SELECT * FROM tbl WHERE ^{mkIdent name} = #{val}|]+"SELECT * FROM tbl WHERE \"name\" = 'some ''value'''"++And more comples example:++>>> let name = Just "name"+>>> let size = Just 10+>>> let active = Nothing :: Maybe Bool+>>> let condlist = catMaybes [ fmap (\a -> [sqlExp|name = #{a}|]) name, fmap (\a -> [sqlExp|size = #{a}|]) size, fmap (\a -> [sqlExp|active = #{a}|]) active]+>>> let cond = if L.null condlist then mempty else [sqlExp| WHERE ^{mconcat $ L.intersperse " AND " $ condlist} |]+>>> runSqlBuilder c [sqlExp|SELECT * FROM tbl ^{cond} -- line comment|]+"SELECT * FROM tbl WHERE name = 'name' AND size = 10 "++-}++sqlExp :: QuasiQuoter+sqlExp = QuasiQuoter+ { quoteExp = sqlQExp+ , quotePat = error "sqlInt used in pattern"+ , quoteType = error "sqlInt used in type"+ , quoteDec = error "sqlInt used in declaration"+ }++-- | 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 __^{..}__+ deriving (Ord, Eq, Show)++parseRope :: String -> [Rope]+parseRope s = either error id+ $ parseOnly ropeParser+ $ T.pack s++ropeParser :: Parser [Rope]+ropeParser = many1 $ choice+ [ quoted+ , iquoted+ , ropeint+ , ropepaste+ , comment+ , bcomment+ , spaces+ , (RLit . T.singleton) <$> anyChar+ ]+ where+ eofErf e p =+ choice+ [ endOfInput+ *> (error $ "Unexpected end of input: " <> e)+ , p+ ]++ unquoteBraces = T.replace "\\}" "}"++ ropeint = do+ _ <- string "#{"+ e <- many1 $ choice+ [ string "\\}"+ , T.singleton <$> notChar '}'+ ]+ _ <- char '}'+ return $ RInt $ unquoteBraces $ mconcat e++ ropepaste = do+ _ <- string "^{"+ e <- many1 $ choice+ [ string "\\}"+ , T.singleton <$> notChar '}'+ ]+ _ <- char '}'+ return $ RPaste $ unquoteBraces $ mconcat e++ comment = do+ b <- string "--"+ c <- takeWhile (`notElem` ['\r', '\n'])+ endOfLine <|> endOfInput+ return $ RComment $ b <> c+ spaces = (RSpaces . T.length) <$> takeWhile1 isSpace++ bcomment :: Parser Rope+ bcomment = RComment <$> go+ where+ go = do+ b <- string "/*"+ c <- many' $ choice+ [ go+ , justStar+ , T.singleton <$> notChar '*'+ ]+ eofErf "block comment not finished, maybe typo" $ do+ e <- string "*/"+ return $ b <> mconcat c <> e+ justStar = do+ _ <- char '*'+ peekChar >>= \case+ (Just '/') -> fail "no way"+ _ -> return "*"++ quoted = do+ _ <- char '\''+ ret <- many' $ choice+ [ string "''"+ , string "\\'"+ , T.singleton <$> notChar '\''+ ]+ eofErf "string literal not finished" $ do+ _ <- char '\''+ return $ RLit $ "'" <> mconcat ret <> "'"++ iquoted = do+ _ <- char '"'+ ret <- many' $ choice+ [ string "\"\""+ , T.singleton <$> notChar '"'+ ]+ eofErf "quoted identifier not finished" $ do+ _ <- char '"'+ return $ RLit $ "\"" <> mconcat ret <> "\""+++-- | Build builder from rope+buildBuilder :: Exp -- ^ Expression of type 'Query'+ -> Rope+ -> Maybe (Q Exp)+buildBuilder _ (RLit t) = Just $ do+ bs <- bsToExp $ T.encodeUtf8 t+ [e| toSqlBuilder $(pure bs) |]+buildBuilder q (RInt 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+ 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 _) = " "++-- | Removes sequential occurencies of 'RLit' constructors. Also+-- removes commentaries and squash sequences of spaces to single space+-- symbol+squashRope :: [Rope] -> [Rope]+squashRope = go . catMaybes . map cleanRope+ where+ cleanRope (RComment _) = Nothing+ cleanRope (RSpaces _) = Just $ RLit " "+ cleanRope x = Just x++ go ((RLit a):(RLit b):xs) = go ((RLit $ a <> b):xs)+ go (x:xs) = x:(go xs)+ go [] = []++-- | Build expression of type 'SqlBuilder' from SQL query with interpolation+sqlQExp :: String+ -> Q Exp -- ^ Expression of type 'SqlBuilder'+sqlQExp s = do+ let rope = squashRope+ $ parseRope s+ q <- buildQ rope+ exps <- sequence+ $ catMaybes+ $ map (buildBuilder q) rope+ [e| ( mconcat $(pure $ ListE exps) ) |]++{- | Embed sql template and perform interpolation++@+let name = "name"+ foo = "bar"+ query = $(sqlExpEmbed "sql/foo/bar.sql") -- using 'foo' and 'bar' inside+@+-}++sqlExpEmbed :: String -- ^ file path+ -> Q Exp -- ^ Expression of type 'SqlBuilder'+sqlExpEmbed fpath = do+ qAddDependentFile fpath+ s <- runIO $ T.unpack . T.decodeUtf8 <$> B.readFile fpath+ sqlQExp s++{- | Just like 'sqlExpEmbed' but uses pattern instead of file+name. So, code++@+let query = $(sqlExpFile "foo/bar")+@++is just the same as++@+let query = $(sqlExpEmbed "sql/foo/bar.sql")+@++This function inspired by Yesod's 'widgetFile'+-}++sqlExpFile :: String+ -> Q Exp+sqlExpFile ptr = sqlExpEmbed $ "sql/" <> ptr <> ".sql"
+ src/Database/PostgreSQL/Query/Types.hs view
@@ -0,0 +1,369 @@+module Database.PostgreSQL.Query.Types+ ( -- * Query execution+ HasPostgres(..)+ , TransactionSafe+ , PgMonadT(..)+ , runPgMonadT+ , launchPG+ -- * Auxiliary types+ , InetText(..)+ , FN(..)+ , textFN+ , MarkedRow(..)+ , mrToBuilder+ , ToMarkedRow(..)+ ) where++import Prelude++import Control.Applicative+import Control.Monad+import Control.Monad.Base ( MonadBase(..) )+import Control.Monad.Catch+ ( MonadThrow, MonadMask, MonadCatch )+import Control.Monad.Cont.Class ( MonadCont )+import Control.Monad.Error.Class ( MonadError )+import Control.Monad.Fix ( MonadFix(..) )+import Control.Monad.Logger+import Control.Monad.Reader+ ( MonadReader(..), ReaderT(..) )+import Control.Monad.State.Class ( MonadState )+import Control.Monad.Trans+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Control+import Control.Monad.Trans.Either+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Writer.Class ( MonadWriter )+import Data.Monoid+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 GHC.Generics++import qualified Data.List as L+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.Text as T+import qualified Data.Text.Encoding as T++{- $setup+>>> import PGSimple.SqlBuilder+>>> c <- connect defaultConnectInfo+-}+++-- | type to put and get from db 'inet' and 'cidr' typed postgresql+-- fields. This should be in postgresql-simple in fact.+newtype InetText =+ InetText+ { unInetText :: T.Text+ } deriving ( IsString, Eq, Ord, Read, Show+ , Typeable, Monoid, ToField )++instance FromField InetText where+ fromField fld Nothing = returnError ConversionFailed+ fld "can not convert Null to InetText"+ fromField fld (Just bs) = do+ n <- typename fld+ case n of+ "inet" -> result+ "cidr" -> result+ _ -> returnError+ ConversionFailed fld+ "could not convert to InetText"+ where+ result = return $ InetText+ $ T.decodeUtf8 bs++++{- | Dote separated field name. Each element in nested list will be+properly quoted and separated by dot. It also have instance of+'ToSqlBuilder' and 'IsString` so you can:++>>> let a = "hello" :: FN+>>> a+FN ["hello"]++>>> let b = "user.name" :: FN+>>> b+FN ["user","name"]++>>> let n = "u.name" :: FN+>>> runSqlBuilder c $ toSqlBuilder n+"\"u\".\"name\""++>>> ("user" <> "name") :: FN+FN ["user","name"]++>>> let a = "name" :: FN+>>> let b = "email" :: FN+>>> runSqlBuilder c [sqlExp|^{"u" <> a} = 'name', ^{"e" <> b} = 'email'|]+"\"u\".\"name\" = 'name', \"e\".\"email\" = 'email'"++-}++newtype FN =+ FN [Text]+ deriving (Ord, Eq, Show, Monoid, Typeable, Generic)++instance ToSqlBuilder FN where+ toSqlBuilder (FN tt) =+ mconcat+ $ L.intersperse "."+ $ map mkIdent tt++instance IsString FN where+ fromString s =+ FN+ $ map T.pack+ $ filter (/= ".")+ $ L.groupBy f s+ where+ f a b = not $ a == '.' || b == '.'++{- | Single field to 'FN'++>>> textFN "hello"+FN ["hello"]++>>> textFN "user.name"+FN ["user.name"]++Note that it does not split string to parts by point like instance of+`IsString` does++-}++textFN :: Text -> FN+textFN = FN . (:[])++{- | Marked row is list of pairs of field name and some sql+expression. Used to generate queries like:++@+name = 'name' AND size = 10 AND length = 20+@++or++@+UPDATE tbl SET name = 'name', size = 10, lenght = 20+@++-}++newtype MarkedRow =+ MR+ { unMR :: [(FN, SqlBuilder)]+ } deriving (Monoid, Typeable, Generic)++class ToMarkedRow a where+ -- | generate list of pairs (field name, field value)+ toMarkedRow :: a -> MarkedRow++instance ToMarkedRow MarkedRow where+ toMarkedRow = id++{- | Turns marked row to query intercalating it with other builder++>>> runSqlBuilder c $ mrToBuilder "AND" $ MR [("name", mkValue "petr"), ("email", mkValue "foo@bar.com")]+" \"name\" = 'petr' AND \"email\" = 'foo@bar.com' "++-}++mrToBuilder :: SqlBuilder -- ^ Builder to intercalate with+ -> MarkedRow+ -> SqlBuilder+mrToBuilder b (MR l) = mconcat+ $ L.intersperse b+ $ map tobld l+ where+ tobld (f, val) = [sqlExp| ^{f} = ^{val} |]+++-- | Instances of this typeclass can acquire connection and pass it to+-- computation. It can be reader of pool of connections or just reader of+-- connection++class (MonadBase IO m) => HasPostgres m where+ withPGConnection :: (Connection -> m a) -> m a++instance (HasPostgres m) => HasPostgres (EitherT e m) where+ withPGConnection action = do+ EitherT $ withPGConnection $ \con -> do+ runEitherT $ action con+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m) => HasPostgres (ExceptT e m) where+ withPGConnection action = do+ ExceptT $ withPGConnection $ \con -> do+ runExceptT $ action con+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m) => HasPostgres (IdentityT m) where+ withPGConnection action = do+ IdentityT $ withPGConnection $ \con -> do+ runIdentityT $ action con+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m) => HasPostgres (MaybeT m) where+ withPGConnection action = do+ MaybeT $ withPGConnection $ \con -> do+ runMaybeT $ action con+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m) => HasPostgres (ReaderT r m) where+ withPGConnection action = do+ ReaderT $ \r -> withPGConnection $ \con ->+ runReaderT (action con) r+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m) => HasPostgres (STL.StateT s m) where+ withPGConnection action = do+ STL.StateT $ \s -> withPGConnection $ \con ->+ STL.runStateT (action con) s+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m) => HasPostgres (STS.StateT s m) where+ withPGConnection action = do+ STS.StateT $ \s -> withPGConnection $ \con ->+ STS.runStateT (action con) s+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m) => HasPostgres (ContT r m) where+ withPGConnection action = do+ ContT $ \r -> withPGConnection $ \con ->+ runContT (action con) r+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m, Monoid w) => HasPostgres (WL.WriterT w m) where+ withPGConnection action = do+ WL.WriterT $ withPGConnection $ \con ->+ WL.runWriterT (action con)+ {-# INLINABLE withPGConnection #-}++instance (HasPostgres m, Monoid w) => HasPostgres (WS.WriterT w m) where+ withPGConnection action = do+ WS.WriterT $ withPGConnection $ \con ->+ WS.runWriterT (action con)+ {-# INLINABLE withPGConnection #-}++-- | Empty typeclass signing monad in which transaction is+-- safe. i.e. `PgMonadT` have this instance, but some other monad giving+-- connection from e.g. connection pool is not.+class TransactionSafe (m :: * -> *)++instance (TransactionSafe m) => TransactionSafe (EitherT e m)+instance (TransactionSafe m) => TransactionSafe (ExceptT e m)+instance (TransactionSafe m) => TransactionSafe (IdentityT m)+instance (TransactionSafe m) => TransactionSafe (MaybeT m)+instance (TransactionSafe m) => TransactionSafe (ReaderT r m)+instance (TransactionSafe m) => TransactionSafe (STL.StateT s m)+instance (TransactionSafe m) => TransactionSafe (STS.StateT s m)+instance (TransactionSafe m) => TransactionSafe (ContT r m)+instance (TransactionSafe m, Monoid w) => TransactionSafe (WL.WriterT w m)+instance (TransactionSafe m, Monoid w) => TransactionSafe (WS.WriterT w m)+++-- | Reader of connection. Has instance of 'HasPostgres'. So if you have a+-- connection you can run queries in this monad using 'runPgMonadT'. Or you+-- can use this transformer to run sequence of queries using same+-- connection with 'launchPG'.+newtype PgMonadT m a =+ PgMonadT+ { unPgMonadT :: ReaderT Connection m a+ } deriving ( Functor, Applicative, Monad , MonadWriter w+ , MonadState s, MonadError e, MonadTrans+ , Alternative, MonadFix, MonadPlus, MonadIO+ , MonadCont, MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadLogger )++#if MIN_VERSION_monad_control(1,0,0)+instance (MonadBaseControl b m) => MonadBaseControl b (PgMonadT m) where+ type StM (PgMonadT m) a = StM (ReaderT Connection m) a+ liftBaseWith action = PgMonadT $ do+ liftBaseWith $ \runInBase -> action (runInBase . unPgMonadT)+ restoreM st = PgMonadT $ restoreM st+ {-# INLINABLE liftBaseWith #-}+ {-# INLINABLE restoreM #-}++instance MonadTransControl PgMonadT where+ type StT PgMonadT a = StT (ReaderT Connection) a+ liftWith action = PgMonadT $ do+ liftWith $ \runTrans -> action (runTrans . unPgMonadT)+ restoreT st = PgMonadT $ restoreT st+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}+#else+instance (MonadBaseControl b m) => MonadBaseControl b (PgMonadT m) where+ newtype StM (PgMonadT m) a+ = PgMTM (StM (ReaderT Connection m) a)+ liftBaseWith action = PgMonadT $ do+ liftBaseWith $ \runInBase -> do+ action ((PgMTM `liftM`) . runInBase . unPgMonadT)+ restoreM (PgMTM st) = PgMonadT $ restoreM st+ {-# INLINABLE liftBaseWith #-}+ {-# INLINABLE restoreM #-}++instance MonadTransControl PgMonadT where+ newtype StT PgMonadT a+ = PgMTT+ { unPgMTT :: StT (ReaderT Connection) a+ }+ liftWith action = PgMonadT $ do+ liftWith $ \runTrans -> do -- ReaderT Connection n a -> n (StT (ReaderT Connection n) a)+ action ((PgMTT `liftM`) . runTrans . unPgMonadT)+ restoreT st = PgMonadT $ restoreT $ unPgMTT `liftM` st+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}+#endif++instance (MonadReader r m) => MonadReader r (PgMonadT m) where+ ask = lift ask+ local md ac = do+ con <- PgMonadT ask+ lift $ do+ local md $ runPgMonadT con ac+ reader = lift . reader+ {-# INLINABLE ask #-}+ {-# INLINABLE local #-}+ {-# INLINABLE reader #-}++instance (MonadBase IO m) => HasPostgres (PgMonadT m) where+ withPGConnection action = do+ con <- PgMonadT ask+ action con+ {-# INLINABLE withPGConnection #-}++instance TransactionSafe (PgMonadT m)+++runPgMonadT :: Connection -> PgMonadT m a -> m a+runPgMonadT con (PgMonadT action) = runReaderT action con++{- | If your monad have instance of 'HasPostgres' you maybe dont need this+function, unless your instance use 'withPGPool' which acquires connection+from pool for each query. If you want to run sequence of queries using same+connection you need this function++-}++launchPG :: (HasPostgres m)+ => PgMonadT m a+ -> m a+launchPG act = withPGConnection $ \con -> do+ runPgMonadT con act
+ test/Main.hs view
@@ -0,0 +1,125 @@+{-# 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 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