Merge pull request #16 from bogiebro/master

Insert select statements

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
+  Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported.
-  are available, but most of them can be easily added (especially
+  Not all SQL features are available, but most of them can be easily added
-  functions), so please open an issue or send a pull request if
+  (especially functions), so please open an issue or send a pull request if
   you need anything that is not covered by @esqueleto@ on
   <https://github.com/meteficha/esqueleto/>.
   .

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,
+-- We re-export many symbols from @persistent@ for convenince
--- since @esqueleto@ currently does not provide a way of doing
--- @INSERT@s:
---
 --  * \"Store functions\" from "Database.Persist".
 --
 --  * Everything from "Database.Persist.Class" except for

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 :: SqlSelect a r => Mode -> QueryType a -> Connection -> SqlQuery a -> (TLB.Builder, [PersistValue])
-toRawSql mode conn query =
+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

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)]
+
 
 ----------------------------------------------------------------------