diff --git a/esqueleto.cabal b/esqueleto.cabal index afd9957..061af10 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 7bad01b..59830de 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 @@ -318,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 10addcd..193448e 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(..), (<$>), (<$)) @@ -224,9 +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 (Insertion a) EEntity :: Ident -> SqlExpr (Entity val) EMaybe :: SqlExpr a -> SqlExpr (Maybe a) ERaw :: NeedParens -> (Connection -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) @@ -371,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 conn query +sub mode query = ERaw Parens $ \conn -> toRawSql mode pureQuery conn query fromDBName :: Connection -> DBName -> TLB.Builder fromDBName conn = TLB.fromText . connEscapeName conn @@ -379,7 +385,7 @@ fromDBName conn = TLB.fromText . connEscapeName conn existsHelper :: SqlQuery () -> SqlExpr (Value a) existsHelper = ERaw Parens . - flip (toRawSql SELECT) . + flip (toRawSql SELECT pureQuery) . (>> return (val True :: SqlExpr (Value Bool))) ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) @@ -488,7 +494,7 @@ rawSelectSource mode query = src run conn = uncurry rawQuery $ first builderToText $ - toRawSql mode conn query + toRawSql mode pureQuery conn query massage = do mrow <- C.await @@ -600,7 +606,7 @@ rawEsqueleto mode query = do conn <- SqlPersistT R.ask uncurry rawExecuteCount $ first builderToText $ - toRawSql mode conn query + toRawSql mode pureQuery conn query -- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s @@ -684,14 +690,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 => 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 - [ makeSelect conn mode ret + [ makeInsert qt ret + , makeSelect conn mode ret , makeFrom conn mode fromClauses , makeSet conn setClauses , makeWhere conn whereClauses @@ -704,6 +711,21 @@ toRawSql mode conn query = -- | (Internal) Mode of query being converted by 'toRawSql'. data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE +newtype QueryType a = QueryType { unQueryType :: a -> TLB.Builder } + +pureQuery :: QueryType a +pureQuery = QueryType (const mempty) + +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" + +makeInsert :: QueryType a -> a -> (TLB.Builder, [PersistValue]) +makeInsert q a = (unQueryType q a, []) uncommas :: [TLB.Builder] -> TLB.Builder uncommas = mconcat . intersperse ", " . filter (/= mempty) @@ -840,6 +862,14 @@ class SqlSelect a r | a -> r, r -> a where sqlSelectProcessRow :: [PersistValue] -> Either T.Text r +-- | 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 + sqlSelectProcessRow = const (Right Proxy) + + -- | Not useful for 'select', but used for 'update' and 'delete'. instance SqlSelect () () where sqlSelectCols _ _ = ("1", []) @@ -1386,3 +1416,31 @@ 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 +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 (SqlExpr (Insertion a)) r, PersistEntity a) => + SqlQuery (SqlExpr (Insertion a)) -> SqlPersistT m () +insertSelectDistinct = insertGeneralSelect SELECT_DISTINCT + + +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 insertQuery 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)] + ----------------------------------------------------------------------