diff --git a/esqueleto.cabal b/esqueleto.cabal index f721f44..947d601 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,5 +1,5 @@ name: esqueleto -version: 1.3.3 +version: 1.3.4.2 synopsis: Bare bones, type-safe EDSL for SQL queries on persistent backends. homepage: https://github.com/meteficha/esqueleto license: BSD3 @@ -47,6 +47,14 @@ source-repository head type: git location: git://github.com/meteficha/esqueleto.git +Flag postgresql + Description: test postgresql. default is to test sqlite. + Default: False + +Flag mysql + Description: test MySQL/MariaDB. default is to test sqlite. + Default: False + library exposed-modules: Database.Esqueleto @@ -90,3 +98,20 @@ test-suite test -- This library , esqueleto + + if flag(postgresql) + build-depends: + postgresql-simple >= 0.2 + , postgresql-libpq >= 0.6 + , persistent-postgresql >= 1.2.0 + + cpp-options: -DWITH_POSTGRESQL + + if flag(mysql) + build-depends: + mysql-simple >= 0.2.2.3 + , mysql >= 0.1.1.3 + , persistent-mysql >= 1.2.0 + + cpp-options: -DWITH_MYSQL + diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs index b245550..b737f77 100644 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -27,6 +27,7 @@ module Database.Esqueleto.Internal.Language , OnClauseWithoutMatchingJoinException(..) , OrderBy , Update + , Insertion -- * The guts , JoinKind(..) , IsJoinKind(..) @@ -307,6 +308,12 @@ class (Functor query, Applicative query, Monad query) => (*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) (/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Value a) -> expr (Update val) + -- | Apply a 'PersistField' constructor to @expr Value@ arguments. + (<#) :: (a -> b) -> expr (Value a) -> expr (Insertion b) + + -- | Apply extra @expr Value@ arguments to a 'PersistField' constructor + (<&>) :: expr (Insertion (a -> b)) -> expr (Value a) -> expr (Insertion b) + -- Fixity declarations infixl 9 ^. @@ -492,6 +499,10 @@ data OrderBy data Update typ +-- | Phantom type used by 'insertSelect'. +data Insertion a + + -- | @FROM@ clause: bring entities into scope. -- -- This function internally uses two type classes in order to diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 910a8c7..e4156cd 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -23,6 +23,8 @@ module Database.Esqueleto.Internal.Sql , deleteCount , update , updateCount + , insertSelectDistinct + , insertSelect -- * The guts , unsafeSqlBinOp , unsafeSqlValue @@ -33,12 +35,11 @@ module Database.Esqueleto.Internal.Sql , rawEsqueleto , toRawSql , Mode(..) + , IdentState + , initialIdentState + , IdentInfo , SqlSelect , veryUnsafeCoerceSqlExprValue - , insertSelectDistinct - , insertSelect - , (<#) - , (<&>) ) where import Control.Applicative (Applicative(..), (<$>), (<$)) @@ -221,27 +222,49 @@ newIdentFor = Q . lift . try . unDBName return (I t) +-- | Information needed to escape and use identifiers. +type IdentInfo = (Connection, IdentState) + + -- | Use an identifier. -useIdent :: Connection -> Ident -> TLB.Builder -useIdent conn (I ident) = fromDBName conn $ DBName ident +useIdent :: IdentInfo -> Ident -> TLB.Builder +useIdent info (I ident) = fromDBName info $ DBName ident ---------------------------------------------------------------------- -type Insertion = Proxy -- | An expression on the SQL backend. data SqlExpr a where - EInsert :: Proxy a -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) + -- An entity, created by 'from' (cf. 'fromStart'). EEntity :: Ident -> SqlExpr (Entity val) + + -- Just a tag stating that something is nullable. EMaybe :: SqlExpr a -> SqlExpr (Maybe a) - ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) - EList :: SqlExpr (Value a) -> SqlExpr (ValueList a) + + -- Raw expression: states whether parenthesis are needed + -- around this expression, and takes information about the SQL + -- connection (mainly for escaping names) and returns both an + -- string ('TLB.Builder') and a list of values to be + -- interpolated by the SQL backend. + ERaw :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) + + -- 'EList' and 'EEmptyList' are used by list operators. + EList :: SqlExpr (Value a) -> SqlExpr (ValueList a) EEmptyList :: SqlExpr (ValueList a) + + -- A 'SqlExpr' accepted only by 'orderBy'. EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy - ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) + + -- A 'SqlExpr' accepted only by 'set'. + ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) + + -- An internal 'SqlExpr' used by the 'from' hack. EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a) + -- Used by 'insertSelect'. + EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) + data NeedParens = Parens | Never parensM :: NeedParens -> TLB.Builder -> TLB.Builder @@ -301,7 +324,7 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where sub_selectDistinct = sub SELECT_DISTINCT EEntity ident ^. field = - ERaw Never $ \conn -> (useIdent conn ident <> ("." <> fieldName conn field), []) + ERaw Never $ \info -> (useIdent info ident <> ("." <> fieldName info field), []) EMaybe r ?. field = maybelize (r ^. field) where @@ -315,10 +338,10 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where nothing = unsafeSqlValue "NULL" joinV (ERaw p f) = ERaw p f countRows = unsafeSqlValue "COUNT(*)" - count (ERaw _ f) = ERaw Never $ \conn -> let (b, vals) = f conn + count (ERaw _ f) = ERaw Never $ \info -> let (b, vals) = f info in ("COUNT" <> parens b, vals) - not_ (ERaw p f) = ERaw Never $ \conn -> let (b, vals) = f conn + not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info in ("NOT " <> parensM p b, vals) (==.) = unsafeSqlBinOp " = " @@ -371,32 +394,39 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where field *=. expr = setAux field (\ent -> ent ^. field *. expr) field /=. expr = setAux field (\ent -> ent ^. field /. expr) + (<#) _ (ERaw _ f) = EInsert Proxy f + + (EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x -> + let (fb, fv) = f x + (gb, gv) = g x + in (fb <> ", " <> gb, fv ++ gv) + instance ToSomeValues SqlExpr (SqlExpr (Value a)) where toSomeValues a = [SomeValue a] fieldName :: (PersistEntity val, PersistField typ) - => Connection -> EntityField val typ -> TLB.Builder -fieldName conn = fromDBName conn . fieldDB . persistFieldDef + => IdentInfo -> EntityField val typ -> TLB.Builder +fieldName info = fromDBName info . fieldDB . persistFieldDef setAux :: (PersistEntity val, PersistField typ) => EntityField val typ -> (SqlExpr (Entity val) -> SqlExpr (Value typ)) -> SqlExpr (Update val) setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) - where name = ERaw Never $ \conn -> (fieldName conn field, mempty) + where name = ERaw Never $ \info -> (fieldName info field, mempty) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) -sub mode query = ERaw Parens $ \conn -> toRawSql mode pureQuery conn query +sub mode query = ERaw Parens $ \info -> toRawSql mode pureQuery info query -fromDBName :: Connection -> DBName -> TLB.Builder -fromDBName conn = TLB.fromText . connEscapeName conn +fromDBName :: IdentInfo -> DBName -> TLB.Builder +fromDBName (conn, _) = TLB.fromText . connEscapeName conn -existsHelper :: SqlQuery () -> SqlExpr (Value a) -existsHelper = - ERaw Parens . - flip (toRawSql SELECT pureQuery) . - (>> return (val True :: SqlExpr (Value Bool))) +existsHelper :: SqlQuery () -> SqlExpr (Value Bool) +existsHelper = sub SELECT . (>> return true) + where + true :: SqlExpr (Value Bool) + true = val True ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) ifNotEmptyList EEmptyList b _ = val b @@ -421,8 +451,8 @@ ifNotEmptyList (EList _) _ x = x unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f where - f conn = let (b1, vals1) = f1 conn - (b2, vals2) = f2 conn + f info = let (b1, vals1) = f1 info + (b2, vals2) = f2 info in ( parensM p1 b1 <> op <> parensM p2 b2 , vals1 <> vals2 ) {-# INLINE unsafeSqlBinOp #-} @@ -440,9 +470,9 @@ unsafeSqlValue v = ERaw Never $ \_ -> (v, mempty) unsafeSqlFunction :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlFunction name arg = - ERaw Never $ \conn -> + ERaw Never $ \info -> let (argsTLB, argsVals) = - uncommas' $ map (\(ERaw _ f) -> f conn) $ toArgList arg + uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList arg in (name <> parens argsTLB, argsVals) class UnsafeSqlFunctionArgument a where @@ -504,7 +534,7 @@ rawSelectSource mode query = src run conn = uncurry rawQuery $ first builderToText $ - toRawSql mode pureQuery conn query + toRawSql mode pureQuery (conn, initialIdentState) query massage = do mrow <- C.await @@ -616,7 +646,7 @@ rawEsqueleto mode query = do conn <- SqlPersistT R.ask uncurry rawExecuteCount $ first builderToText $ - toRawSql mode pureQuery conn query + toRawSql mode pureQuery (conn, initialIdentState) query -- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s @@ -700,24 +730,37 @@ builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize -- @esqueleto@, instead of manually using this function (which is -- possible but tedious), you may just turn on query logging of -- @persistent@. -toRawSql :: SqlSelect a r => Mode -> QueryType a -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue]) -toRawSql mode qt conn query = - let (ret, SideData fromClauses setClauses whereClauses groupByClause havingClause orderByClauses limitClause) = - flip S.evalState initialIdentState $ +toRawSql :: SqlSelect a r => Mode -> QueryType a -> IdentInfo -> SqlQuery a -> (TLB.Builder, [PersistValue]) +toRawSql mode qt (conn, firstIdentState) query = + let ((ret, sd), finalIdentState) = + flip S.runState firstIdentState $ W.runWriterT $ unQ query + SideData fromClauses + setClauses + whereClauses + groupByClause + havingClause + orderByClauses + limitClause = sd + -- Pass the finalIdentState (containing all identifiers + -- that were used) to the subsequent calls. This ensures + -- that no name clashes will occur on subqueries that may + -- appear on the expressions below. + info = (conn, finalIdentState) in mconcat [ makeInsert qt ret - , makeSelect conn mode ret - , makeFrom conn mode fromClauses - , makeSet conn setClauses - , makeWhere conn whereClauses - , makeGroupBy conn groupByClause - , makeHaving conn havingClause - , makeOrderBy conn orderByClauses - , makeLimit conn limitClause + , makeSelect info mode ret + , makeFrom info mode fromClauses + , makeSet info setClauses + , makeWhere info whereClauses + , makeGroupBy info groupByClause + , makeHaving info havingClause + , makeOrderBy info orderByClauses + , makeLimit info limitClause ] + -- | (Internal) Mode of query being converted by 'toRawSql'. data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE @@ -744,21 +787,21 @@ uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a) uncommas' = (uncommas *** mconcat) . unzip -makeSelect :: SqlSelect a r => Connection -> Mode -> a -> (TLB.Builder, [PersistValue]) -makeSelect conn mode ret = +makeSelect :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue]) +makeSelect info mode ret = case mode of SELECT -> withCols "SELECT " SELECT_DISTINCT -> withCols "SELECT DISTINCT " DELETE -> plain "DELETE " UPDATE -> plain "UPDATE " where - withCols v = first (v <>) (sqlSelectCols conn ret) + withCols v = first (v <>) (sqlSelectCols info ret) plain v = (v, []) -makeFrom :: Connection -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue]) +makeFrom :: IdentInfo -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue]) makeFrom _ _ [] = mempty -makeFrom conn mode fs = ret +makeFrom info mode fs = ret where ret = case collectOnClauses fs of Left expr -> throw $ mkExc expr @@ -779,8 +822,8 @@ makeFrom conn mode fs = ret base ident@(I identText) def = let db@(DBName dbText) = entityDB def in ( if dbText == identText - then fromDBName conn db - else fromDBName conn db <> (" AS " <> useIdent conn ident) + then fromDBName info db + else fromDBName info db <> (" AS " <> useIdent info ident) , mempty ) fromKind InnerJoinKind = " INNER JOIN " @@ -789,56 +832,56 @@ makeFrom conn mode fs = ret fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " fromKind FullOuterJoinKind = " FULL OUTER JOIN " - makeOnClause (ERaw _ f) = first (" ON " <>) (f conn) + makeOnClause (ERaw _ f) = first (" ON " <>) (f info) mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ - TL.unpack $ TLB.toLazyText $ fst (f conn) + TL.unpack $ TLB.toLazyText $ fst (f info) -makeSet :: Connection -> [SetClause] -> (TLB.Builder, [PersistValue]) +makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty -makeSet conn os = first ("\nSET " <>) $ uncommas' (map mk os) +makeSet info os = first ("\nSET " <>) $ uncommas' (map mk os) where - mk (SetClause (ERaw _ f)) = f conn + mk (SetClause (ERaw _ f)) = f info -makeWhere :: Connection -> WhereClause -> (TLB.Builder, [PersistValue]) +makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeWhere _ NoWhere = mempty -makeWhere conn (Where (ERaw _ f)) = first ("\nWHERE " <>) (f conn) +makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info) -makeGroupBy :: Connection -> GroupByClause -> (TLB.Builder, [PersistValue]) +makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) makeGroupBy _ (GroupBy []) = (mempty, []) -makeGroupBy conn (GroupBy fields) = first ("\nGROUP BY " <>) build +makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build where - build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f conn) fields + build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f info) fields -makeHaving :: Connection -> WhereClause -> (TLB.Builder, [PersistValue]) +makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeHaving _ NoWhere = mempty -makeHaving conn (Where (ERaw _ f)) = first ("\nHAVING " <>) (f conn) +makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info) -makeOrderBy :: Connection -> [OrderByClause] -> (TLB.Builder, [PersistValue]) +makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderBy _ [] = mempty -makeOrderBy conn os = first ("\nORDER BY " <>) $ uncommas' (map mk os) +makeOrderBy info os = first ("\nORDER BY " <>) $ uncommas' (map mk os) where - mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f conn) + mk (EOrderBy t (ERaw p f)) = first ((<> orderByType t) . parensM p) (f info) orderByType ASC = " ASC" orderByType DESC = " DESC" -makeLimit :: Connection -> LimitClause -> (TLB.Builder, [PersistValue]) +makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue]) makeLimit _ (Limit Nothing Nothing) = mempty makeLimit _ (Limit Nothing (Just 0)) = mempty -makeLimit conn (Limit ml mo) = (ret, mempty) +makeLimit info (Limit ml mo) = (ret, mempty) where ret = TLB.singleton '\n' <> (limitTLB <> offsetTLB) limitTLB = case ml of Just l -> "LIMIT " <> TLBI.decimal l - Nothing -> TLB.fromText (connNoLimit conn) + Nothing -> TLB.fromText (connNoLimit $ fst info) offsetTLB = case mo of @@ -863,7 +906,7 @@ 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 -- 'rawQuery'. - sqlSelectCols :: Connection -> a -> (TLB.Builder, [PersistValue]) + sqlSelectCols :: IdentInfo -> a -> (TLB.Builder, [PersistValue]) -- | Number of columns that will be consumed. sqlSelectColCount :: Proxy a -> Int @@ -874,10 +917,11 @@ class SqlSelect a r | a -> r, r -> a where -- | You may return an insertion of some PersistEntity instance PersistEntity a => SqlSelect (SqlExpr (Insertion a)) (Insertion a) where - sqlSelectCols esc (EInsert _ f) = let (b, vals) = f esc - in (b, vals) + sqlSelectCols info (EInsert _ f) = f info sqlSelectColCount = const 0 - sqlSelectProcessRow = const (Right Proxy) + sqlSelectProcessRow = const (Right (error msg)) + where + msg = "sqlSelectProcessRow/SqlSelect (SqlExpr (Insertion a)) (Insertion a): never here" -- | Not useful for 'select', but used for 'update' and 'delete'. @@ -889,10 +933,10 @@ instance SqlSelect () () where -- | You may return an 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where - sqlSelectCols conn expr@(EEntity ident) = ret + sqlSelectCols info expr@(EEntity ident) = ret where process ed = uncommas $ - map ((name <>) . fromDBName conn) $ + map ((name <>) . fromDBName info) $ (entityID ed:) $ map fieldDB $ entityFields ed @@ -902,7 +946,7 @@ instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where -- clause), while 'rawSql' assumes that it's just the -- name of the table (which doesn't allow self-joins, for -- example). - name = useIdent conn ident <> "." + name = useIdent info ident <> "." ret = let ed = entityDef $ getEntityVal $ return expr in (process ed, mempty) sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal @@ -917,7 +961,7 @@ getEntityVal = const Proxy -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where - sqlSelectCols conn (EMaybe ent) = sqlSelectCols conn ent + sqlSelectCols info (EMaybe ent) = sqlSelectCols info ent sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) @@ -930,8 +974,8 @@ instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entit -- | You may return any single value (i.e. a single column) from -- a 'select' query. instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where - sqlSelectCols esc (ERaw p f) = let (b, vals) = f esc - in (parensM p b, vals) + sqlSelectCols info (ERaw p f) = let (b, vals) = f info + in (parensM p b, vals) sqlSelectColCount = const 1 sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv sqlSelectProcessRow _ = Left "SqlSelect (Value a): wrong number of columns." @@ -1427,23 +1471,14 @@ from16P = const Proxy to16 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) --- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments -(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b) -(<#) _ (ERaw _ f) = EInsert Proxy f --- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor -(<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b) -(EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x-> - let (fb, fv) = f x - (gb, gv) = g x - in (fb <> ", " <> gb, fv ++ gv) - --- | Insert a 'PersistField' for every selected value +-- | Insert a 'PersistField' for every selected value. insertSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () insertSelect = insertGeneralSelect SELECT --- | Insert a 'PersistField' for every unique selected value + +-- | Insert a 'PersistField' for every unique selected value. insertSelectDistinct :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT @@ -1453,4 +1488,4 @@ insertGeneralSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr ( Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () insertGeneralSelect mode query = do conn <- SqlPersistT R.ask - uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery conn query + uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery (conn, initialIdentState) query diff --git a/test/Test.hs b/test/Test.hs index 908afa1..b084802 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -10,6 +10,7 @@ , TemplateHaskell , TypeFamilies , ScopedTypeVariables + , CPP #-} module Main (main) where @@ -20,11 +21,22 @@ import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT) import Control.Monad.Trans.Control (MonadBaseControl(..)) import Database.Esqueleto import Database.Persist.Sqlite (withSqliteConn) +#if defined (WITH_POSTGRESQL) +import Database.Persist.Postgresql (withPostgresqlConn) +#elif defined (WITH_MYSQL) +import Database.Persist.MySQL ( withMySQLConn + , connectHost + , connectDatabase + , connectUser + , connectPassword + , defaultConnectInfo) +#endif import Database.Persist.TH import Test.Hspec import qualified Data.Conduit as C import qualified Data.Set as S +import qualified Data.List as L -- Test schema @@ -43,6 +55,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| deriving Eq Show |] +-- | this could be achieved with S.fromList, but not all lists +-- have Ord instances +sameElementsAs :: Eq a => [a] -> [a] -> Bool +sameElementsAs l1 l2 = null (l1 L.\\ l2) main :: IO () main = do @@ -96,10 +112,41 @@ main = do ret <- select $ from $ \(person1, person2) -> return (person1, person2) - liftIO $ ret `shouldBe` [ (p1e, p1e) - , (p1e, p2e) - , (p2e, p1e) - , (p2e, p2e) ] + liftIO $ ret `shouldSatisfy` sameElementsAs [ (p1e, p1e) + , (p1e, p2e) + , (p2e, p1e) + , (p2e, p2e) ] + + it "works for a self-join via sub_select" $ + run $ do + p1k <- insert p1 + p2k <- insert p2 + f1k <- insert (Follow p1k p2k) + f2k <- insert (Follow p2k p1k) + ret <- select $ + from $ \followA -> do + let subquery = + from $ \followB -> do + where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed + return $ followB ^. FollowFollower + where_ $ followA ^. FollowFollowed ==. sub_select subquery + return followA + liftIO $ length ret `shouldBe` 2 + + it "works for a self-join via exists" $ + run $ do + p1k <- insert p1 + p2k <- insert p2 + f1k <- insert (Follow p1k p2k) + f2k <- insert (Follow p2k p1k) + ret <- select $ + from $ \followA -> do + where_ $ exists $ + from $ \followB -> + where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed + return followA + liftIO $ length ret `shouldBe` 2 + it "works for a simple projection" $ run $ do @@ -118,7 +165,8 @@ main = do ret <- select $ from $ \(pa, pb) -> return (pa ^. PersonName, pb ^. PersonName) - liftIO $ ret `shouldBe` [ (Value (personName p1), Value (personName p1)) + liftIO $ ret `shouldSatisfy` sameElementsAs + [ (Value (personName p1), Value (personName p1)) , (Value (personName p1), Value (personName p2)) , (Value (personName p2), Value (personName p1)) , (Value (personName p2), Value (personName p2)) ] @@ -312,7 +360,11 @@ main = do it "works with random_" $ run $ do +#if defined(WITH_POSTGRESQL) || defined(WITH_MYSQL) + ret <- select $ return (random_ :: SqlExpr (Value Double)) +#else ret <- select $ return (random_ :: SqlExpr (Value Int)) +#endif return () it "works with round_" $ @@ -431,7 +483,13 @@ main = do from $ \p -> do orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p + -- in PostgreSQL nulls are bigger than everything +#ifdef WITH_POSTGRESQL + liftIO $ ret `shouldBe` [ p4e, p3e, p1e , p2e ] +#else + -- in SQLite and MySQL, its the reverse liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] +#endif it "works with one ASC and one DESC field" $ run $ do @@ -443,7 +501,11 @@ main = do from $ \p -> do orderBy [desc (p ^. PersonAge), asc (p ^. PersonName)] return p +#ifdef WITH_POSTGRESQL + liftIO $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] +#else liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] +#endif it "works with a sub_select" $ run $ do @@ -547,10 +609,27 @@ main = do from $ \p -> do orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p + -- PostgreSQL: nulls are bigger than data, and update returns + -- matched rows, not actually changed rows. +#if defined(WITH_POSTGRESQL) + liftIO $ n `shouldBe` 2 + liftIO $ ret `shouldBe` [ Entity p1k (Person anon (Just 73)) + , Entity p2k (Person anon Nothing) + , Entity p3k p3 ] + -- MySQL: nulls appear first, and update returns actual number + -- of changed rows +#elif defined(WITH_MYSQL) + liftIO $ n `shouldBe` 1 + liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing) + , Entity p1k (Person anon (Just 73)) + , Entity p3k p3 ] +#else + -- SQLite: nulls appear first, update returns matched rows. liftIO $ n `shouldBe` 2 liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing) , Entity p1k (Person anon (Just 73)) , Entity p3k p3 ] +#endif it "works with a subexpression having COUNT(*)" $ run $ do @@ -724,6 +803,20 @@ insert' v = flip Entity v <$> insert v type RunDbMonad m = ( MonadBaseControl IO m, MonadIO m, MonadLogger m , C.MonadUnsafeIO m, C.MonadThrow m ) +#if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL) +-- With SQLite and in-memory databases, a separate connection implies a +-- separate database. With 'actual databases', the data is persistent and +-- thus must be cleaned after each test. +-- TODO: there is certainly a better way... +cleanDB + :: (forall m. RunDbMonad m + => SqlPersistT (C.ResourceT m) ()) +cleanDB = do + delete $ from $ \(blogpost :: SqlExpr (Entity BlogPost))-> return () + delete $ from $ \(follow :: SqlExpr (Entity Follow)) -> return () + delete $ from $ \(person :: SqlExpr (Entity Person)) -> return () +#endif + run, runSilent, runVerbose :: (forall m. RunDbMonad m => SqlPersistT (C.ResourceT m) a) -> IO a runSilent act = runNoLoggingT $ run_worker act @@ -739,8 +832,23 @@ verbose = True run_worker :: RunDbMonad m => SqlPersistT (C.ResourceT m) a -> m a -run_worker = +run_worker act = C.runResourceT . +#if defined(WITH_POSTGRESQL) + withPostgresqlConn "host=localhost port=5432 user=test dbname=test" . +#elif defined (WITH_MYSQL) + withMySQLConn defaultConnectInfo + { connectHost = "localhost" + , connectUser = "test" + , connectPassword = "test" + , connectDatabase = "test" + } . +#else withSqliteConn ":memory:" . +#endif runSqlConn . - (runMigrationSilent migrateAll >>) +#if defined (WITH_POSTGRESQL) || defined (WITH_MYSQL) + (runMigrationSilent migrateAll >>) $ (cleanDB >> act) +#else + (runMigrationSilent migrateAll >>) $ act +#endif