haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Steal code from rawSql and stop using it.

Browse Source 
Unfortunately we can't use rawSql, since we need explicit control
of the SELECT (i.e. we can't use "??").
This commit is contained in:
Felipe Lessa 2012-09-03 18:43:17 -03:00
parent 2986d0996e
commit 531ca905fd
2 changed files with 170 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
esqueleto.cabal
View File

@ -26,6 +26,6 @@ library
, monad-supply == 0.3.*
, monad-logger
, resourcet
, conduit
hs-source-dirs: src/
ghc-options: -Wall

229
src/Database/Esqueleto/Internal/Sql.hs
View File

@ -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)