persistent 2.7.1 → 2.7.2
raw patch · 7 files changed
+217/−8 lines, 7 filesdep +haskell-src-metanew-uploader
Dependencies added: haskell-src-meta
Files
- ChangeLog.md +5/−0
- Database/Persist/Sql.hs +3/−0
- Database/Persist/Sql/Migration.hs +1/−0
- Database/Persist/Sql/Raw.hs +6/−6
- Database/Persist/Sql/Raw/QQ.hs +196/−0
- Database/Persist/Sql/Types/Internal.hs +3/−1
- persistent.cabal +3/−1
ChangeLog.md view
@@ -1,3 +1,8 @@+## 2.7.2++* Many of the functions have been generalized using the `BackendCompatible` class. [#723](https://github.com/yesodweb/persistent/pull/723)+* Add raw sql quasi quoters [#717](https://github.com/yesodweb/persistent/pull/717)+ ## 2.7.1 * Added an `insertUniqueEntity` function [#718](https://github.com/yesodweb/persistent/pull/718)
Database/Persist/Sql.hs view
@@ -10,6 +10,8 @@ , rawExecute , rawExecuteCount , rawSql+ , sqlQQ+ , executeQQ , deleteWhereCount , updateWhereCount , transactionSave@@ -25,6 +27,7 @@ import Database.Persist.Sql.Class import Database.Persist.Sql.Run hiding (withResourceTimeout) import Database.Persist.Sql.Raw+import Database.Persist.Sql.Raw.QQ import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal
Database/Persist/Sql/Migration.hs view
@@ -27,6 +27,7 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Types+import Database.Persist.Sql.Orphan.PersistStore() allSql :: CautiousMigration -> [Sql] allSql = map snd
Database/Persist/Sql/Raw.hs view
@@ -47,20 +47,20 @@ stmtQuery stmt vals -- | Execute a raw SQL statement-rawExecute :: MonadIO m+rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders.- -> ReaderT SqlBackend m ()+ -> ReaderT backend m () rawExecute x y = liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of -- rows it has modified.-rawExecuteCount :: (MonadIO m, IsSqlBackend backend)+rawExecuteCount :: (MonadIO m, BackendCompatible SqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT backend m Int64 rawExecuteCount sql vals = do- conn <- persistBackend `liftM` ask+ conn <- projectBackend `liftM` ask runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) stmt <- getStmt sql@@ -69,10 +69,10 @@ return res getStmt- :: (MonadIO m, IsSqlBackend backend)+ :: (MonadIO m, BackendCompatible SqlBackend backend) => Text -> ReaderT backend m Statement getStmt sql = do- conn <- persistBackend `liftM` ask+ conn <- projectBackend `liftM` ask liftIO $ getStmtConn conn sql getStmtConn :: SqlBackend -> Text -> IO Statement
+ Database/Persist/Sql/Raw/QQ.hs view
@@ -0,0 +1,196 @@+{-|+@since 2.7.2++Module: module Database.Persist.Sql.Raw.QQ+Description: QuasiQuoters for performing raw sql queries++This module exports convenient QuasiQuoters to perform raw SQL queries.+All QuasiQuoters follow the same pattern and are analogous to the similar named+functions exported from 'Database.Persist.Sql.Raw'. Neither the quoted+function's behaviour, nor it's return value is altered during the translation+and all documentation provided with it holds.++The QuasiQuoters in this module perform a simple substitution on the query text,+that allows value substitutions, table name substitutions as well as column name+substitutions.+-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Database.Persist.Sql.Raw.QQ (+ -- * Sql QuasiQuoters+ queryQQ+ , queryResQQ+ , sqlQQ+ , executeQQ+ , executeCountQQ+ ) where++import Prelude+import Control.Arrow (first, second)+import Control.Monad.Reader (ask)+import Data.Text (pack, unpack)+import Data.Maybe (fromMaybe, Maybe(..))+import Data.Monoid (mempty, (<>))+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+import Language.Haskell.Meta.Parse++import Database.Persist.Class (toPersistValue)+import Database.Persist.Sql.Raw (rawSql, rawQuery, rawQueryRes, rawExecute, rawExecuteCount)+import Database.Persist.Sql.Types (connEscapeName)+import Database.Persist.Sql.Orphan.PersistStore (getFieldName, getTableName)++data Token+ = Literal String+ | Value String+ | TableName String+ | ColumnName String+ deriving Show++parseHaskell :: (String -> Token) -> String -> String -> [Token]+parseHaskell cons = go+ where+ go a [] = [Literal (reverse a)]+ go a ('\\':x:xs) = go (x:a) xs+ go a ['\\'] = go ('\\':a) []+ go a ('}':xs) = cons (reverse a) : parseStr [] xs+ go a (x:xs) = go (x:a) xs++parseStr :: String -> String -> [Token]+parseStr a [] = [Literal (reverse a)]+parseStr a ('\\':x:xs) = parseStr (x:a) xs+parseStr a ['\\'] = parseStr ('\\':a) []+parseStr a ('#':'{':xs) = Literal (reverse a) : parseHaskell Value [] xs+parseStr a ('^':'{':xs) = Literal (reverse a) : parseHaskell TableName [] xs+parseStr a ('@':'{':xs) = Literal (reverse a) : parseHaskell ColumnName [] xs+parseStr a (x:xs) = parseStr (x:a) xs++makeExpr :: TH.ExpQ -> [Token] -> TH.ExpQ+makeExpr fun toks = do+ TH.infixE+ (Just [| uncurry $(fun) |])+ ([| (=<<) |])+ (Just $ go toks)++ where+ go :: [Token] -> TH.ExpQ+ go [] = [| return (mempty, mempty) |]+ go (Literal a:xs) =+ TH.appE+ [| fmap $ first (pack a <>) |]+ (go xs)+ go (Value a:xs) =+ TH.appE+ [| fmap $ first ("?" <>) . second (toPersistValue $(reifyExp a) :) |]+ (go xs)+ go (ColumnName a:xs) = do+ colN <- TH.newName "field"+ TH.infixE+ (Just [| getFieldName $(reifyExp a) |])+ [| (>>=) |]+ (Just $ TH.lamE [ TH.varP colN ] $+ TH.appE+ [| fmap $ first ($(TH.varE colN) <>) |]+ (go xs))+ go (TableName a:xs) = do+ typeN <- TH.lookupTypeName a >>= \case+ Just t -> return t+ Nothing -> fail $ "Type not in scope: " ++ show a+ tableN <- TH.newName "table"+ TH.infixE+ (Just $+ TH.appE+ [| getTableName |]+ (TH.sigE+ [| error "record" |] $+ (TH.conT typeN)))+ [| (>>=) |]+ (Just $ TH.lamE [ TH.varP tableN ] $+ TH.appE+ [| fmap $ first ($(TH.varE tableN) <>) |]+ (go xs))++reifyExp :: String -> TH.Q TH.Exp+reifyExp s =+ case parseExp s of+ Left e -> TH.reportError e >> [| mempty |]+ Right v -> return v++makeQQ :: TH.Q TH.Exp -> QuasiQuoter+makeQQ x = QuasiQuoter+ (makeExpr x . parseStr [])+ (error "Cannot use qc as a pattern")+ (error "Cannot use qc as a type")+ (error "Cannot use qc as a dec")++-- | QuasiQuoter for performing raw sql queries, analoguous to+-- 'Database.Persist.Sql.Raw.rawSql'+--+-- This and the following are convenient QuasiQuoters to perform raw SQL+-- queries. They each follow the same pattern and are analogous to+-- the similarly named @raw@ functions. Neither the quoted function's+-- behaviour, nor it's return value is altered during the translation and+-- all documentation provided with it holds.+--+-- These QuasiQuoters perform a simple substitution on the query text, that+-- allows value substitutions, table name substitutions as well as column name+-- substitutions.+--+-- Here is a small example:+--+-- Given the following simple model:+--+-- @+-- Category+-- rgt Int+-- lft Int+-- @+--+-- We can now execute this raw query:+--+-- @+-- let lft = 10 :: Int+-- rgt = 20 :: Int+-- width = rgt - lft+-- in [sqlQQ|+-- DELETE FROM ^{Category} WHERE @{CategoryLft} BETWEEN #{lft} AND #{rgt};+-- UPDATE category SET @{CategoryRgt} = @{CategoryRgt} - #{width} WHERE @{CategoryRgt} > #{rgt};+-- UPDATE category SET @{CategoryLft} = @{CategoryLft} - #{width} WHERE @{CategoryLft} > #{rgt};+-- |]+-- @+--+-- @^{TableName}@ looks up the table's name and escapes it, @\@{ColumnName}@+-- looks up the column's name and properly escapes it and @#{value}@ inserts+-- the value via the usual parameter substitution mechanism.+--+-- @since 2.7.2+sqlQQ :: QuasiQuoter+sqlQQ = makeQQ [| rawSql |]++-- | Analoguous to 'Database.Persist.Sql.Raw.rawExecute'+--+-- @since 2.7.2+executeQQ :: QuasiQuoter+executeQQ = makeQQ [| rawExecute |]++-- | Analoguous to 'Database.Persist.Sql.Raw.rawExecuteCount'+--+-- @since 2.7.2+executeCountQQ :: QuasiQuoter+executeCountQQ = makeQQ [| rawExecuteCount |]++-- | Analoguous to 'Database.Persist.Sql.Raw.rawQuery'+--+-- @since 2.7.2+queryQQ :: QuasiQuoter+queryQQ = makeQQ [| rawQuery |]++-- | Analoguous to 'Database.Persist.Sql.Raw.rawQueryRes'+--+-- @since 2.7.2+queryResQQ :: QuasiQuoter+queryResQQ = makeQQ [| rawQueryRes |]
Database/Persist/Sql/Types/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -39,6 +40,7 @@ , PersistQueryRead, PersistQueryWrite , PersistStoreRead, PersistStoreWrite , PersistUniqueRead, PersistUniqueWrite+ , BackendCompatible(..) ) import Database.Persist.Class.PersistStore (IsPersistBackend (..)) import Database.Persist.Types@@ -130,7 +132,7 @@ -- | A constraint synonym which witnesses that a backend is SQL and can run read queries. type SqlBackendCanRead backend =- ( IsSqlBackend backend+ ( BackendCompatible SqlBackend backend , PersistQueryRead backend, PersistStoreRead backend, PersistUniqueRead backend ) -- | A constraint synonym which witnesses that a backend is SQL and can run read and write queries.
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.7.1+version: 2.7.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -45,6 +45,7 @@ , vector , attoparsec , template-haskell+ , haskell-src-meta , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , silently@@ -75,6 +76,7 @@ Database.Persist.Sql.Internal Database.Persist.Sql.Types Database.Persist.Sql.Raw+ Database.Persist.Sql.Raw.QQ Database.Persist.Sql.Run Database.Persist.Sql.Class Database.Persist.Sql.Orphan.PersistQuery