Add upsert support and allow arbitrary queries in INSERT, UPDATE and …

…DELETE This PR makes several changes to our "manipulation" functions (`insert`, `update`, `delete`). Firstly, we now support `ON CONFLICT DO UPDATE`, aka "upsert". Secondly, we now allow the insertion of arbitrary queries (not just static `VALUES`). `values` recovers the old behaviour. Thirdly, the `WHERE` clauses of `UPDATE` and `DELETE` are now also arbitrary queries (allowing joining against other tables and the use of functions like `absent` and `present`). `where_` recovers the old behaviour. In terms of generating the SQL to implement these features, it was unfortunately significantly less work to roll our own here than to add this upstream to Opaleye proper, because it would have required more refactoring than I felt comfortable doing.
circuithub · Jun 29, 2021 · c0cee0c · c0cee0c
1 parent 3025f48
commit c0cee0c
Show file tree

Hide file tree

Showing 15 changed files with 374 additions and 260 deletions.
diff --git a/rel8.cabal b/rel8.cabal
@@ -27,6 +27,7 @@ library
     , contravariant
     , hasql ^>= 1.4.5.1
     , opaleye ^>= 0.7.3.0
+    , pretty
     , profunctors
     , scientific
     , semialign
@@ -143,7 +144,7 @@ library
 
     Rel8.Statement.Delete
     Rel8.Statement.Insert
-    Rel8.Statement.Returning
+    Rel8.Statement.Manipulation
     Rel8.Statement.Select
     Rel8.Statement.Update
     Rel8.Statement.View

diff --git a/src/Rel8.hs b/src/Rel8.hs
@@ -256,15 +256,18 @@ module Rel8
     -- ** @INSERT@
   , Insert(..)
   , OnConflict(..)
+  , Upsert(..)
   , insert
 
     -- ** @DELETE@
   , Delete(..)
   , delete
 
     -- ** @UPDATE@
-  , update
   , Update(..)
+  , Set
+  , Where
+  , update
 
     -- ** @.. RETURNING@
   , Returning(..)
@@ -332,7 +335,7 @@ import Rel8.Schema.Result ( Result )
 import Rel8.Schema.Table
 import Rel8.Statement.Delete
 import Rel8.Statement.Insert
-import Rel8.Statement.Returning
+import Rel8.Statement.Manipulation
 import Rel8.Statement.Select
 import Rel8.Statement.Update
 import Rel8.Statement.View

diff --git a/src/Rel8/Query/SQL.hs b/src/Rel8/Query/SQL.hs
@@ -5,6 +5,7 @@
 module Rel8.Query.SQL
   ( showQuery
   , sqlForQuery, sqlForQueryWithNames
+  , ppSelect
   )
 where
 
@@ -22,6 +23,9 @@ import qualified Opaleye.Internal.Optimize as Opaleye
 import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )
 import qualified Opaleye.Internal.Sql as Opaleye
 
+-- pretty
+import Text.PrettyPrint ( Doc )
+
 -- rel8
 import Rel8.Expr ( Expr, Col( E ) )
 import Rel8.Expr.Opaleye ( toPrimExpr )
@@ -40,15 +44,18 @@ showQuery :: Table Expr a => Query a -> String
 showQuery = fold . sqlForQuery
 
 
-sqlForQuery :: Table Expr a
-  => Query a -> Maybe String
+sqlForQuery :: Table Expr a => Query a -> Maybe String
 sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
 
 
 sqlForQueryWithNames :: Selects names exprs
   => names -> Query exprs -> Maybe String
-sqlForQueryWithNames names query =
-  show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
+sqlForQueryWithNames names query = show <$> ppSelect names query
+
+
+ppSelect :: Selects names exprs => names -> Query exprs -> Maybe Doc
+ppSelect names query =
+  Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
   where
     (exprs, primQuery, _) =
       Opaleye.runSimpleQueryArrStart (toOpaleye query) ()

diff --git a/src/Rel8/Schema/Name.hs b/src/Rel8/Schema/Name.hs
@@ -16,6 +16,7 @@ module Rel8.Schema.Name
   ( Name(..)
   , Col( N, unN )
   , Selects
+  , ppColumn
   )
 where
 
@@ -25,6 +26,13 @@ import Data.Kind ( Constraint, Type )
 import Data.String ( IsString, fromString )
 import Prelude
 
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
+
+-- pretty
+import Text.PrettyPrint ( Doc )
+
 -- rel8
 import Rel8.Expr ( Expr )
 import Rel8.Schema.Context ( Interpretation, Col )
@@ -91,3 +99,7 @@ instance Interpretation Name where
 type Selects :: Type -> Type -> Constraint
 class Recontextualize Name Expr names exprs => Selects names exprs
 instance Recontextualize Name Expr names exprs => Selects names exprs
+
+
+ppColumn :: String -> Doc
+ppColumn = Opaleye.ppSqlExpr . Opaleye.ColumnSqlExpr . Opaleye.SqlColumn
diff --git a/src/Rel8/Schema/Table.hs b/src/Rel8/Schema/Table.hs
@@ -1,14 +1,24 @@
 {-# language DeriveFunctor #-}
 {-# language DerivingStrategies #-}
+{-# language DisambiguateRecordFields #-}
+{-# language NamedFieldPuns #-}
 
 module Rel8.Schema.Table
   ( TableSchema(..)
+  , ppTable
   )
 where
 
 -- base
 import Prelude
 
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
+import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
+
+-- pretty
+import Text.PrettyPrint ( Doc )
+
 
 -- | The schema for a table. This is used to specify the name and schema that a
 -- table belongs to (the @FROM@ part of a SQL query), along with the schema of
@@ -27,3 +37,10 @@ data TableSchema names = TableSchema
     -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor.
   }
   deriving stock Functor
+
+
+ppTable :: TableSchema a -> Doc
+ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable
+  { sqlTableSchemaName = schema
+  , sqlTableName = name
+  }
diff --git a/src/Rel8/Statement/Delete.hs b/src/Rel8/Statement/Delete.hs
@@ -1,19 +1,15 @@
-{-# language DuplicateRecordFields #-}
 {-# language GADTs #-}
 {-# language NamedFieldPuns #-}
 {-# language ScopedTypeVariables #-}
-{-# language StandaloneKindSignatures #-}
 {-# language TypeApplications #-}
 
 module Rel8.Statement.Delete
-  ( Delete(..)
-  , delete
+  ( delete
   )
 where
 
 -- base
 import Control.Exception ( throwIO )
-import Data.Kind ( Type )
 import Prelude
 
 -- hasql
@@ -23,69 +19,41 @@ import qualified Hasql.Encoders as Hasql
 import qualified Hasql.Session as Hasql
 import qualified Hasql.Statement as Hasql
 
--- opaleye
-import qualified Opaleye.Internal.Manipulation as Opaleye
-
 -- rel8
-import Rel8.Expr ( Expr )
-import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
-import Rel8.Schema.Name ( Selects )
-import Rel8.Schema.Table ( TableSchema )
-import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )
-import Rel8.Table ( fromColumns, toColumns )
-import Rel8.Table.Opaleye ( castTable, table, unpackspec )
+import Rel8.Statement.Manipulation ( Delete(..), Returning(..), ppDelete )
 import Rel8.Table.Serialize ( Serializable, parse )
 
 -- text
 import qualified Data.Text as Text
 import Data.Text.Encoding ( encodeUtf8 )
 
 
--- | The constituent parts of a @DELETE@ statement.
-type Delete :: Type -> Type
-data Delete a where
-  Delete :: Selects names exprs =>
-    { from :: TableSchema names
-      -- ^ Which table to delete from.
-    , deleteWhere :: exprs -> Expr Bool
-      -- ^ Which rows should be selected for deletion.
-    , returning :: Returning names a
-      -- ^ What to return from the @DELETE@ statement.
-    }
-    -> Delete a
-
-
 -- | Run a @DELETE@ statement.
 delete :: Connection -> Delete a -> IO a
-delete c Delete {from, deleteWhere, returning} =
-  case returning of
-    NumberOfRowsAffected -> Hasql.run session c >>= either throwIO pure
+delete c d@Delete {returning} =
+  case (show <$> ppDelete d, returning) of
+    (Nothing, NumberOfRowsAffected) -> pure 0
+    (Nothing, Projection _) -> pure []
+    (Just sql, NumberOfRowsAffected) ->
+      Hasql.run session c >>= either throwIO pure
       where
         session = Hasql.statement () statement
         statement = Hasql.Statement bytes params decode prepare
         bytes = encodeUtf8 $ Text.pack sql
         params = Hasql.noParams
         decode = Hasql.rowsAffected
         prepare = False
-        sql = Opaleye.arrangeDeleteSql from' where'
-          where
-            from' = table $ toColumns <$> from
-            where' = toColumn . toPrimExpr . deleteWhere . fromColumns
 
-    Projection project -> Hasql.run session c >>= either throwIO pure
+    (Just sql, Projection project) ->
+      Hasql.run session c >>= either throwIO pure
       where
         session = Hasql.statement () statement
         statement = Hasql.Statement bytes params decode prepare
         bytes = encodeUtf8 $ Text.pack sql
         params = Hasql.noParams
         decode = decoder project
         prepare = False
-        sql =
-          Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'
-          where
-            from' = table $ toColumns <$> from
-            where' = toColumn . toPrimExpr . deleteWhere . fromColumns
-            project' = castTable . toColumns . project . fromColumns
+
   where
     decoder :: forall exprs projection a. Serializable projection a
       => (exprs -> projection) -> Hasql.Result [a]

diff --git a/src/Rel8/Statement/Insert.hs b/src/Rel8/Statement/Insert.hs
@@ -1,21 +1,15 @@
-{-# language DuplicateRecordFields #-}
 {-# language GADTs #-}
 {-# language NamedFieldPuns #-}
 {-# language ScopedTypeVariables #-}
-{-# language StandaloneKindSignatures #-}
 {-# language TypeApplications #-}
 
 module Rel8.Statement.Insert
-  ( Insert(..)
-  , OnConflict(..)
-  , insert
+  ( insert
   )
 where
 
 -- base
 import Control.Exception ( throwIO )
-import Data.List.NonEmpty ( NonEmpty( (:|) ) )
-import Data.Kind ( Type )
 import Prelude
 
 -- hasql
@@ -25,94 +19,41 @@ import qualified Hasql.Encoders as Hasql
 import qualified Hasql.Session as Hasql
 import qualified Hasql.Statement as Hasql
 
--- opaleye
-import qualified Opaleye.Internal.Manipulation as Opaleye
-import qualified Opaleye.Manipulation as Opaleye
-
 -- rel8
-import Rel8.Schema.Name ( Selects )
-import Rel8.Schema.Table ( TableSchema )
-import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
-import Rel8.Table ( fromColumns, toColumns )
-import Rel8.Table.Opaleye ( castTable, table, unpackspec )
+import Rel8.Statement.Manipulation ( Insert(..), Returning(..), ppInsert )
 import Rel8.Table.Serialize ( Serializable, parse )
 
 -- text
 import qualified Data.Text as Text ( pack )
 import Data.Text.Encoding ( encodeUtf8 )
 
 
--- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
--- statement.
-type OnConflict :: Type
-data OnConflict
-  = Abort     -- ^ @ON CONFLICT ABORT@
-  | DoNothing -- ^ @ON CONFLICT DO NOTHING@
-
-
--- | The constituent parts of a SQL @INSERT@ statement.
-type Insert :: Type -> Type
-data Insert a where
-  Insert :: Selects names exprs =>
-    { into :: TableSchema names
-      -- ^ Which table to insert into.
-    , rows :: [exprs]
-      -- ^ The rows to insert.
-    , onConflict :: OnConflict
-      -- ^ What to do if the inserted rows conflict with data already in the
-      -- table.
-    , returning :: Returning names a
-      -- ^ What information to return on completion.
-    }
-    -> Insert a
-
-
 -- | Run an @INSERT@ statement
 insert :: Connection -> Insert a -> IO a
-insert c Insert {into, rows, onConflict, returning} =
-  case (rows, returning) of
-    ([], NumberOfRowsAffected) -> pure 0
-    ([], Projection _) -> pure []
+insert c i@Insert {returning} =
+  case (show <$> ppInsert i, returning) of
+    (Nothing, NumberOfRowsAffected) -> pure 0
+    (Nothing, Projection _) -> pure []
 
-    (x:xs, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure
+    (Just sql, NumberOfRowsAffected) -> Hasql.run session c >>= either throwIO pure
       where
         session = Hasql.statement () statement
         statement = Hasql.Statement bytes params decode prepare
         bytes = encodeUtf8 $ Text.pack sql
         params = Hasql.noParams
         decode = Hasql.rowsAffected
         prepare = False
-        sql = Opaleye.arrangeInsertManySql into' rows' onConflict'
-          where
-            into' = table $ toColumns <$> into
-            rows' = toColumns <$> x :| xs
 
-    (x:xs, Projection project) -> Hasql.run session c >>= either throwIO pure
+    (Just sql, Projection project) -> Hasql.run session c >>= either throwIO pure
       where
         session = Hasql.statement () statement
         statement = Hasql.Statement bytes params decode prepare
         bytes = encodeUtf8 $ Text.pack sql
         params = Hasql.noParams
         decode = decoder project
         prepare = False
-        sql =
-          Opaleye.arrangeInsertManyReturningSql
-            unpackspec
-            into'
-            rows'
-            project'
-            onConflict'
-          where
-            into' = table $ toColumns <$> into
-            rows' = toColumns <$> x :| xs
-            project' = castTable . toColumns . project . fromColumns
 
   where
-    onConflict' =
-      case onConflict of
-        DoNothing -> Just Opaleye.DoNothing
-        Abort     -> Nothing
-
     decoder :: forall exprs projection a. Serializable projection a
       => (exprs -> projection) -> Hasql.Result [a]
     decoder _ = Hasql.rowList (parse @projection @a)