From ee8656adf050b650a7d93f99a47e1f7e71db9aa6 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sat, 22 Jun 2013 23:48:08 +0900 Subject: [PATCH 1/2] insert select statements --- src/Database/Esqueleto.hs | 4 ++ src/Database/Esqueleto/Internal/Sql.hs | 75 +++++++++++++++++++++++--- test/Test.hs | 12 +++++ 3 files changed, 84 insertions(+), 7 deletions(-) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index 7bad01b..62bbb6c 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -71,6 +71,10 @@ module Database.Esqueleto , deleteCount , update , updateCount + , insertSelect + , insertSelectDistinct + , (<#) + , (<&>) -- * Helpers , valkey diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 10addcd..ed051f0 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -35,6 +35,10 @@ module Database.Esqueleto.Internal.Sql , Mode(..) , SqlSelect , veryUnsafeCoerceSqlExprValue + , insertSelectDistinct + , insertSelect + , (<#) + , (<&>) ) where import Control.Applicative (Applicative(..), (<$>), (<$)) @@ -227,6 +231,7 @@ useIdent conn (I ident) = fromDBName conn $ DBName ident -- | An expression on the SQL backend. data SqlExpr a where + EInsert :: Proxy a -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Proxy a) EEntity :: Ident -> SqlExpr (Entity val) EMaybe :: SqlExpr a -> SqlExpr (Maybe a) ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) @@ -371,7 +376,7 @@ setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) where name = ERaw Never $ \conn -> (fieldName conn field, mempty) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) -sub mode query = ERaw Parens $ \conn -> toRawSql mode conn query +sub mode query = ERaw Parens $ \conn -> toRawSql mode Query conn query fromDBName :: Connection -> DBName -> TLB.Builder fromDBName conn = TLB.fromText . connEscapeName conn @@ -379,7 +384,7 @@ fromDBName conn = TLB.fromText . connEscapeName conn existsHelper :: SqlQuery () -> SqlExpr (Value a) existsHelper = ERaw Parens . - flip (toRawSql SELECT) . + flip (toRawSql SELECT Query) . (>> return (val True :: SqlExpr (Value Bool))) ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) @@ -488,7 +493,7 @@ rawSelectSource mode query = src run conn = uncurry rawQuery $ first builderToText $ - toRawSql mode conn query + toRawSql mode Query conn query massage = do mrow <- C.await @@ -600,7 +605,7 @@ rawEsqueleto mode query = do conn <- SqlPersistT R.ask uncurry rawExecuteCount $ first builderToText $ - toRawSql mode conn query + toRawSql mode Query conn query -- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s @@ -684,14 +689,15 @@ 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 -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue]) -toRawSql mode conn query = +toRawSql :: (SqlSelect a r, SqlInsert t a) => Mode -> t -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue]) +toRawSql mode t conn query = let (ret, SideData fromClauses setClauses whereClauses groupByClause havingClause orderByClauses limitClause) = flip S.evalState initialIdentState $ W.runWriterT $ unQ query in mconcat - [ makeSelect conn mode ret + [ makeInsert t ret + , makeSelect conn mode ret , makeFrom conn mode fromClauses , makeSet conn setClauses , makeWhere conn whereClauses @@ -704,6 +710,25 @@ toRawSql mode conn query = -- | (Internal) Mode of query being converted by 'toRawSql'. data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE +data Query = Query +data Insertion = Insertion + +class SqlInsert t a where + getTable :: t -> a -> TLB.Builder + +instance PersistEntity a => SqlInsert Insertion (SqlExpr (Proxy a)) where + getTable _ (EInsert p _) = + let def = entityDef p + unName = TLB.fromText . unDBName + fields = uncommas $ map (unName . fieldDB) (entityFields def) + table = unName . entityDB . entityDef $ p + in "INSERT INTO " <> table <> parens fields <> "\n" + +instance SqlInsert Query a where + getTable _ _ = mempty + +makeInsert :: SqlInsert t a => t -> a -> (TLB.Builder, [PersistValue]) +makeInsert t a = (getTable t a, []) uncommas :: [TLB.Builder] -> TLB.Builder uncommas = mconcat . intersperse ", " . filter (/= mempty) @@ -840,6 +865,15 @@ class SqlSelect a r | a -> r, r -> a where sqlSelectProcessRow :: [PersistValue] -> Either T.Text r +-- | You may return any single value (i.e. a single column) from +-- a 'select' query. +instance PersistField a => SqlSelect (SqlExpr (Proxy a)) (Proxy a) where + sqlSelectCols esc (EInsert _ f) = let (b, vals) = f esc + in (b, vals) + sqlSelectColCount = const 0 + sqlSelectProcessRow = const (Right Proxy) + + -- | Not useful for 'select', but used for 'update' and 'delete'. instance SqlSelect () () where sqlSelectCols _ _ = ("1", []) @@ -1386,3 +1420,30 @@ 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 (Proxy b) +(<#) _ (ERaw _ f) = EInsert Proxy f + +-- | Pair SqlExpr Value arguments, inserting commas +(<&>) :: SqlExpr (Proxy (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Proxy 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 +insertSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect a r, SqlInsert Insertion a) => + SqlQuery a -> SqlPersistT m () +insertSelect = insertQuery SELECT + +-- | Insert a PersistField for every unique selected value +insertSelectDistinct :: (MonadLogger m, MonadResourceBase m, SqlSelect a r, SqlInsert Insertion a) => + SqlQuery a -> SqlPersistT m () +insertSelectDistinct = insertQuery SELECT_DISTINCT + +insertQuery :: (MonadLogger m, MonadResourceBase m, SqlSelect a r, SqlInsert Insertion a) => + Mode -> SqlQuery a -> SqlPersistT m () +insertQuery mode query = do + conn <- SqlPersistT R.ask + uncurry rawExecute $ first builderToText $ toRawSql mode Insertion conn query diff --git a/test/Test.hs b/test/Test.hs index 35acca4..05f12a5 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -9,6 +9,7 @@ , Rank2Types , TemplateHaskell , TypeFamilies + , ScopedTypeVariables #-} module Main (main) where @@ -623,6 +624,17 @@ main = do return p liftIO $ ret `shouldBe` [ Entity p2k p2 ] + describe "inserts by select" $ do + it "IN works for insertSelect" $ + run $ do + _ <- insert p1 + _ <- insert p2 + _ <- insert p3 + insertSelect $ from $ \p -> do + return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) + ret <- select $ from (\(b::(SqlExpr (Entity BlogPost))) -> return countRows) + liftIO $ ret `shouldBe` [Value (3::Int)] + ---------------------------------------------------------------------- From dc5baefd483bb82e43a18a508926cbe5a87514a8 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 30 Jun 2013 11:44:24 +0900 Subject: [PATCH 2/2] No more MPTCs, added documentation --- esqueleto.cabal | 6 +-- src/Database/Esqueleto.hs | 27 +++++++--- src/Database/Esqueleto/Internal/Sql.hs | 73 ++++++++++++-------------- 3 files changed, 59 insertions(+), 47 deletions(-) diff --git a/esqueleto.cabal b/esqueleto.cabal index 07e732b..0aecd18 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -33,9 +33,9 @@ description: compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . - Currently only @SELECT@s are supported. Not all SQL features - are available, but most of them can be easily added (especially - functions), so please open an issue or send a pull request if + Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported. + Not all SQL features are available, but most of them can be easily added + (especially functions), so please open an issue or send a pull request if you need anything that is not covered by @esqueleto@ on . . diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index 62bbb6c..59830de 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -322,17 +322,32 @@ import qualified Database.Persist -- from $ \\p -> do -- where_ (p ^. PersonAge <. just (val 14)) -- @ - - +-- +-- The results of queries can also be used for insertions. +-- In @SQL@, we might write the following, inserting a new blog +-- post for every user: +-- +-- @ +-- INSERT INTO BlogPost +-- SELECT ('Group Blog Post', id) +-- FROM Person +-- @ +-- +-- In @esqueleto@, we may write the same query above as: +-- +-- @ +-- insertSelect $ from $ \p-> +-- return $ BlogPost \<# \"Group Blog Post\" \<&\> (p ^. PersonId) +-- @ +-- +-- Individual insertions can be performed through Persistent's +-- 'insert' function, reexported for convenience. ---------------------------------------------------------------------- -- $reexports -- --- We re-export many symbols from @persistent@ for convenince, --- since @esqueleto@ currently does not provide a way of doing --- @INSERT@s: --- +-- We re-export many symbols from @persistent@ for convenince -- * \"Store functions\" from "Database.Persist". -- -- * Everything from "Database.Persist.Class" except for diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index ed051f0..193448e 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -228,10 +228,11 @@ useIdent conn (I ident) = fromDBName conn $ DBName ident ---------------------------------------------------------------------- +type Insertion = Proxy -- | An expression on the SQL backend. data SqlExpr a where - EInsert :: Proxy a -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Proxy a) + EInsert :: Proxy a -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) EEntity :: Ident -> SqlExpr (Entity val) EMaybe :: SqlExpr a -> SqlExpr (Maybe a) ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) @@ -376,7 +377,7 @@ setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) where name = ERaw Never $ \conn -> (fieldName conn field, mempty) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) -sub mode query = ERaw Parens $ \conn -> toRawSql mode Query conn query +sub mode query = ERaw Parens $ \conn -> toRawSql mode pureQuery conn query fromDBName :: Connection -> DBName -> TLB.Builder fromDBName conn = TLB.fromText . connEscapeName conn @@ -384,7 +385,7 @@ fromDBName conn = TLB.fromText . connEscapeName conn existsHelper :: SqlQuery () -> SqlExpr (Value a) existsHelper = ERaw Parens . - flip (toRawSql SELECT Query) . + flip (toRawSql SELECT pureQuery) . (>> return (val True :: SqlExpr (Value Bool))) ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) @@ -493,7 +494,7 @@ rawSelectSource mode query = src run conn = uncurry rawQuery $ first builderToText $ - toRawSql mode Query conn query + toRawSql mode pureQuery conn query massage = do mrow <- C.await @@ -605,7 +606,7 @@ rawEsqueleto mode query = do conn <- SqlPersistT R.ask uncurry rawExecuteCount $ first builderToText $ - toRawSql mode Query conn query + toRawSql mode pureQuery conn query -- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s @@ -689,14 +690,14 @@ 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, SqlInsert t a) => Mode -> t -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue]) -toRawSql mode t conn query = +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 $ W.runWriterT $ unQ query in mconcat - [ makeInsert t ret + [ makeInsert qt ret , makeSelect conn mode ret , makeFrom conn mode fromClauses , makeSet conn setClauses @@ -710,25 +711,21 @@ toRawSql mode t conn query = -- | (Internal) Mode of query being converted by 'toRawSql'. data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE -data Query = Query -data Insertion = Insertion +newtype QueryType a = QueryType { unQueryType :: a -> TLB.Builder } -class SqlInsert t a where - getTable :: t -> a -> TLB.Builder +pureQuery :: QueryType a +pureQuery = QueryType (const mempty) -instance PersistEntity a => SqlInsert Insertion (SqlExpr (Proxy a)) where - getTable _ (EInsert p _) = +insertQuery :: PersistEntity a => QueryType (SqlExpr (Insertion a)) +insertQuery = QueryType $ \(EInsert p _)-> let def = entityDef p unName = TLB.fromText . unDBName fields = uncommas $ map (unName . fieldDB) (entityFields def) table = unName . entityDB . entityDef $ p in "INSERT INTO " <> table <> parens fields <> "\n" -instance SqlInsert Query a where - getTable _ _ = mempty - -makeInsert :: SqlInsert t a => t -> a -> (TLB.Builder, [PersistValue]) -makeInsert t a = (getTable t a, []) +makeInsert :: QueryType a -> a -> (TLB.Builder, [PersistValue]) +makeInsert q a = (unQueryType q a, []) uncommas :: [TLB.Builder] -> TLB.Builder uncommas = mconcat . intersperse ", " . filter (/= mempty) @@ -865,9 +862,8 @@ class SqlSelect a r | a -> r, r -> a where sqlSelectProcessRow :: [PersistValue] -> Either T.Text r --- | You may return any single value (i.e. a single column) from --- a 'select' query. -instance PersistField a => SqlSelect (SqlExpr (Proxy a)) (Proxy 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) sqlSelectColCount = const 0 @@ -1421,29 +1417,30 @@ 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 (Proxy b) +-- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments +(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b) (<#) _ (ERaw _ f) = EInsert Proxy f --- | Pair SqlExpr Value arguments, inserting commas -(<&>) :: SqlExpr (Proxy (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Proxy b) +-- | 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 -insertSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect a r, SqlInsert Insertion a) => - SqlQuery a -> SqlPersistT m () -insertSelect = insertQuery SELECT +-- | 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 -insertSelectDistinct :: (MonadLogger m, MonadResourceBase m, SqlSelect a r, SqlInsert Insertion a) => - SqlQuery a -> SqlPersistT m () -insertSelectDistinct = insertQuery SELECT_DISTINCT +-- | 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 -insertQuery :: (MonadLogger m, MonadResourceBase m, SqlSelect a r, SqlInsert Insertion a) => - Mode -> SqlQuery a -> SqlPersistT m () -insertQuery mode query = do + +insertGeneralSelect :: (MonadLogger m, MonadResourceBase m, SqlSelect (SqlExpr (Insertion a)) r, PersistEntity a) => + Mode -> SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () +insertGeneralSelect mode query = do conn <- SqlPersistT R.ask - uncurry rawExecute $ first builderToText $ toRawSql mode Insertion conn query + uncurry rawExecute $ first builderToText $ toRawSql mode insertQuery conn query