diff --git a/esqueleto.cabal b/esqueleto.cabal index e7a32d9..37c0641 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -26,6 +26,6 @@ library , monad-supply == 0.3.* , monad-logger - , resourcet + , conduit hs-source-dirs: src/ ghc-options: -Wall diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index f057e3e..63bdf29 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -7,19 +7,23 @@ module Database.Esqueleto.Internal.Sql ) where import Control.Applicative (Applicative(..), (<$>)) -import Control.Arrow (first, (&&&)) +import Control.Arrow (first) import Control.Monad (ap) +import Control.Monad.IO.Class (MonadIO) import Control.Monad.Logger (MonadLogger) -import Control.Monad.Trans.Resource (MonadResourceBase) import Data.List (intersperse) import Data.Monoid (Monoid(..), (<>)) import Database.Persist.EntityDef import Database.Persist.GenericSql import Database.Persist.GenericSql.Internal (Connection(escapeName)) +import Database.Persist.GenericSql.Raw (withStmt) import Database.Persist.Store import qualified Control.Monad.Supply as S import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.Writer as W +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB @@ -57,7 +61,7 @@ instance Monoid SideData where data FromClause = From Ident EntityDef --- | A complere @WHERE@ clause. +-- | A complete @WHERE@ clause. data WhereClause = Where (SqlExpr (Single Bool)) | NoWhere @@ -69,7 +73,7 @@ instance Monoid WhereClause where -- | Identifier used for tables. -newtype Ident = I TLB.Builder +newtype Ident = I TLB.Builder -- | Infinite list of identifiers. @@ -138,18 +142,44 @@ binop op (ERaw f1) (ERaw f2) = ERaw f , vals1 <> vals2 ) +-- | Execute an Esqueleto's 'SqlQuery' inside @persistent@'s +-- 'SqlPersist' monad. +selectSource :: ( SqlSelect a r + , C.MonadResource m + , MonadLogger m + , MonadIO m ) + => SqlQuery a -> SqlPersist m (C.Source (SqlPersist m) r) +selectSource query = src + where + src = do + conn <- getConnection + return $ run conn C.$= massage + + run conn = + uncurry withStmt $ + first (TL.toStrict . TLB.toLazyText) $ + toRawSelectSql (fromDBName conn) query + + massage = do + mrow <- C.await + case process <$> mrow of + Just (Right r) -> C.yield r >> massage + Just (Left err) -> fail (T.unpack err) + Nothing -> return () + + process = sqlSelectProcessRow + + -- | Execute an Esqueleto's 'SqlQuery' inside @persistent@'s -- 'SqlPersist' monad. select :: ( SqlSelect a r - , RawSql r + , C.MonadResource m , MonadLogger m - , MonadResourceBase m) + , MonadIO m ) => SqlQuery a -> SqlPersist m [r] select query = do - conn <- getConnection - uncurry rawSql $ - first (TL.toStrict . TLB.toLazyText) $ - toRawSelectSql (fromDBName conn) query + src <- selectSource query + src C.$$ CL.consume -- | Get current database 'Connection'. @@ -165,8 +195,8 @@ toRawSelectSql esc query = W.runWriterT $ unQ query - (selectText, selectVars) = makeSelect esc ret - (whereText, whereVars) = makeWhere esc whereClauses + (_, selectText, selectVars) = sqlSelectCols esc ret + ( whereText, whereVars) = makeWhere esc whereClauses text = mconcat [ "SELECT " @@ -181,8 +211,10 @@ toRawSelectSql esc query = uncommas :: [TLB.Builder] -> TLB.Builder uncommas = mconcat . intersperse ", " -uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a) -uncommas' = uncommas . map fst &&& mconcat . map snd +uncommas' :: Monoid a => [(Int, TLB.Builder, a)] -> (Int, TLB.Builder, a) +uncommas' xs = + let (as, bs, cs) = unzip3 xs + in (sum as, uncommas bs, mconcat cs) makeFrom :: Escape -> [FromClause] -> TLB.Builder @@ -202,47 +234,105 @@ parens b = "(" <> (b <> "(") -- | Class for mapping results coming from 'SqlQuery' into actual -- results. -class RawSql r => SqlSelect a r | a -> r, r -> a where - makeSelect :: Escape -> a -> (TLB.Builder, [PersistValue]) +-- +-- This looks very similar to @RawSql@, and it is! However, +-- there are some crucial differences and ultimately they're +-- different classes. +class SqlSelect a r | a -> r, r -> a where + -- | Creates the variable part of the @SELECT@ query and + -- returns the list of 'PersistValue's that will be given to + -- 'withStmt'. + sqlSelectCols :: Escape -> a -> (Int, TLB.Builder, [PersistValue]) + + -- | Transform a row of the result into the data type. + sqlSelectProcessRow :: [PersistValue] -> Either T.Text r + instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where - makeSelect _ (EEntity _) = ("??", mempty) + sqlSelectCols escape expr@(EEntity (I ident)) = ret + where + process ed = uncommas $ + map ((name <>) . escape) $ + (entityID ed:) $ + map fieldDB $ + entityFields ed + -- 'name' is the biggest difference between 'RawSql' and + -- 'SqlSelect'. We automatically create names for tables + -- (since it's not the user who's writing the FROM + -- clause), while 'rawSql' assumes that it's just the + -- name of the table (which doesn't allow self-joins, for + -- example). + name = ident <> "." + ret = let ed = entityDef $ getEntityVal expr + in (length (entityFields ed) + 1, process ed, mempty) + getEntityVal :: SqlExpr (Entity a) -> a + getEntityVal = error "Database.Esqueleto.SqlSelect.getEntityVal" + sqlSelectProcessRow (idCol:ent) = + Entity <$> fromPersistValue idCol + <*> fromPersistValues ent + sqlSelectProcessRow _ = Left "SqlSelect (Entity a): wrong number of columns." instance PersistField a => SqlSelect (SqlExpr (Single a)) (Single a) where - makeSelect esc (ERaw f) = first parens (f esc) + sqlSelectCols esc (ERaw f) = let (b, vals) = f esc + in (1, parens b, vals) + sqlSelectProcessRow [pv] = Single <$> fromPersistValue pv + sqlSelectProcessRow _ = Left "SqlSelect (Single a): wrong number of columns." instance ( SqlSelect a ra , SqlSelect b rb ) => SqlSelect (a, b) (ra, rb) where - makeSelect esc (a, b) = + sqlSelectCols esc (a, b) = uncommas' - [ makeSelect esc a - , makeSelect esc b + [ sqlSelectCols esc a + , sqlSelectCols esc b ] + sqlSelectProcessRow = + let x = getType processRow + getType :: SqlSelect a r => (z -> Either y (r,x)) -> a + getType = undefined + + (colCountFst, _, _) = sqlSelectCols undefined x + processRow row = + let (rowFst, rowSnd) = splitAt colCountFst row + in (,) <$> sqlSelectProcessRow rowFst + <*> sqlSelectProcessRow rowSnd + + in colCountFst `seq` processRow + -- Avoids recalculating 'colCountFst'. instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc ) => SqlSelect (a, b, c) (ra, rb, rc) where - makeSelect esc (a, b, c) = + sqlSelectCols esc (a, b, c) = uncommas' - [ makeSelect esc a - , makeSelect esc b - , makeSelect esc c + [ sqlSelectCols esc a + , sqlSelectCols esc b + , sqlSelectCols esc c ] + sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow + +to3 :: ((a,b),c) -> (a,b,c) +to3 ((a,b),c) = (a,b,c) + instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc , SqlSelect d rd ) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where - makeSelect esc (a, b, c, d) = + sqlSelectCols esc (a, b, c, d) = uncommas' - [ makeSelect esc a - , makeSelect esc b - , makeSelect esc c - , makeSelect esc d + [ sqlSelectCols esc a + , sqlSelectCols esc b + , sqlSelectCols esc c + , sqlSelectCols esc d ] + sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow + +to4 :: ((a,b),(c,d)) -> (a,b,c,d) +to4 ((a,b),(c,d)) = (a,b,c,d) + instance ( SqlSelect a ra , SqlSelect b rb @@ -250,14 +340,19 @@ instance ( SqlSelect a ra , SqlSelect d rd , SqlSelect e re ) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where - makeSelect esc (a, b, c, d, e) = + sqlSelectCols esc (a, b, c, d, e) = uncommas' - [ makeSelect esc a - , makeSelect esc b - , makeSelect esc c - , makeSelect esc d - , makeSelect esc e + [ sqlSelectCols esc a + , sqlSelectCols esc b + , sqlSelectCols esc c + , sqlSelectCols esc d + , sqlSelectCols esc e ] + sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow + +to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e) +to5 ((a,b),(c,d),e) = (a,b,c,d,e) + instance ( SqlSelect a ra , SqlSelect b rb @@ -266,15 +361,20 @@ instance ( SqlSelect a ra , SqlSelect e re , SqlSelect f rf ) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where - makeSelect esc (a, b, c, d, e, f) = + sqlSelectCols esc (a, b, c, d, e, f) = uncommas' - [ makeSelect esc a - , makeSelect esc b - , makeSelect esc c - , makeSelect esc d - , makeSelect esc e - , makeSelect esc f + [ sqlSelectCols esc a + , sqlSelectCols esc b + , sqlSelectCols esc c + , sqlSelectCols esc d + , sqlSelectCols esc e + , sqlSelectCols esc f ] + sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow + +to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f) +to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f) + instance ( SqlSelect a ra , SqlSelect b rb @@ -284,16 +384,21 @@ instance ( SqlSelect a ra , SqlSelect f rf , SqlSelect g rg ) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where - makeSelect esc (a, b, c, d, e, f, g) = + sqlSelectCols esc (a, b, c, d, e, f, g) = uncommas' - [ makeSelect esc a - , makeSelect esc b - , makeSelect esc c - , makeSelect esc d - , makeSelect esc e - , makeSelect esc f - , makeSelect esc g + [ sqlSelectCols esc a + , sqlSelectCols esc b + , sqlSelectCols esc c + , sqlSelectCols esc d + , sqlSelectCols esc e + , sqlSelectCols esc f + , sqlSelectCols esc g ] + sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow + +to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g) +to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g) + instance ( SqlSelect a ra , SqlSelect b rb @@ -304,14 +409,18 @@ instance ( SqlSelect a ra , SqlSelect g rg , SqlSelect h rh ) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where - makeSelect esc (a, b, c, d, e, f, g, h) = + sqlSelectCols esc (a, b, c, d, e, f, g, h) = uncommas' - [ makeSelect esc a - , makeSelect esc b - , makeSelect esc c - , makeSelect esc d - , makeSelect esc e - , makeSelect esc f - , makeSelect esc g - , makeSelect esc h + [ sqlSelectCols esc a + , sqlSelectCols esc b + , sqlSelectCols esc c + , sqlSelectCols esc d + , sqlSelectCols esc e + , sqlSelectCols esc f + , sqlSelectCols esc g + , sqlSelectCols esc h ] + sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow + +to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h) +to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)