Add support for prepared statements

changelog.d/20250428_030850_shane.obrien_prepared.md

@@ -0,0 +1,21 @@
+### Removed
+
+- Removed support for `network-ip`. We still support `iproute`.
+
+### Added
+
+- Add support for prepared statements. To use prepared statements, simply use `prepare run` instead of `run` with a function that passes the parameters to your statement.
+
+- Added new `Encoder` type with three members: `binary`, which is the Hasql binary encoder, `text` which encodes a type in PostgreSQL's text format (needed for nested arrays) and `quote`, which is the does the thing that the function we previously called `encode` does (i.e., `a -> Opaleye.PrimExpr`).
+
+### Changed
+
+- Several changes to `TypeInformation`:
+
+  * Changed the `encode` field of `TypeInformation` to be `Encoder a` instead of `a -> Opaleye.PrimExpr`.
+
+  * Moved the `delimiter` field of `Decoder` into the top level of `TypeInformation`, as it's not "decoding" specific, it's also used when "encoding".
+
+  * Renamed the `parser` field of `Decoder` to `text`, to mirror the `text` field of the new `Encoder` type.
+
+  All of this will break any downstream code that uses a completely custom `DBType` implementation, but anything that uses `ReadShow`, `Enum`, `Composite`, `JSONBEncoded` or `parseTypeInformation` will continue working as before (which should cover all common cases).

rel8.cabal

@@ -1,6 +1,6 @@
 cabal-version:       2.0
 name:                rel8
-version:             1.6.0.0
+version:             1.7.0.0
 synopsis:            Hey! Hey! Can u rel8?
 license:             BSD3
 license-file:        LICENSE
@@ -21,20 +21,15 @@ library
   build-depends:
       aeson
     , attoparsec
-    , attoparsec-aeson
     , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19 || ^>= 4.20
     , base16 >= 1.0
     , base-compat ^>= 0.11 || ^>= 0.12 || ^>= 0.13 || ^>= 0.14
     , bifunctors
-    , binary-parser ^>= 0.5
-    , data-dword ^>= 0.3
     , bytestring
     , case-insensitive
     , comonad
     , contravariant
-    , data-textual
-    , hasql >= 1.6.1.2 && < 1.10
-    , network-ip ^>= 0.3
+    , hasql >= 1.8 && < 1.10
     , iproute ^>= 1.7
     , opaleye ^>= 0.10.2.1
     , pretty
@@ -60,6 +55,10 @@ library
     -Wno-monomorphism-restriction
     -Wno-missing-local-signatures
     -Wno-missing-kind-signatures
+    -Wno-missing-role-annotations
+    -Wno-missing-deriving-strategies
+    -Wno-term-variable-capture
+
   hs-source-dirs:
     src
   exposed-modules:
@@ -175,6 +174,7 @@ library
     Rel8.Statement.Delete
     Rel8.Statement.Insert
     Rel8.Statement.OnConflict
+    Rel8.Statement.Prepared
     Rel8.Statement.Returning
     Rel8.Statement.Rows
     Rel8.Statement.Run
@@ -215,16 +215,21 @@ library
 
     Rel8.Type
     Rel8.Type.Array
+    Rel8.Type.Builder.ByteString
+    Rel8.Type.Builder.Fold
+    Rel8.Type.Builder.Time
     Rel8.Type.Composite
     Rel8.Type.Decimal
     Rel8.Type.Decoder
     Rel8.Type.Eq
+    Rel8.Type.Encoder
     Rel8.Type.Enum
     Rel8.Type.Information
     Rel8.Type.JSONEncoded
     Rel8.Type.JSONBEncoded
     Rel8.Type.Monoid
     Rel8.Type.Name
+    Rel8.Type.Nullable
     Rel8.Type.Num
     Rel8.Type.Ord
     Rel8.Type.Parser
@@ -247,12 +252,10 @@ test-suite tests
     , bytestring
     , case-insensitive
     , containers
-    , data-dword
     , hasql
     , hasql-transaction
     , hedgehog          ^>= 1.0 || ^>= 1.1 || ^>= 1.2 || ^>= 1.3 || ^>= 1.4 || ^>= 1.5
     , mmorph
-    , network-ip
     , iproute
     , rel8
     , scientific
@@ -277,3 +280,4 @@ test-suite tests
     -Wno-deprecations -Wno-monomorphism-restriction
     -Wno-missing-local-signatures -Wno-implicit-prelude
     -Wno-missing-kind-signatures
+    -Wno-missing-role-annotations

src/Rel8.hs

@@ -26,6 +26,9 @@ module Rel8
     -- *** @Decoder@
   , Decoder(..)
 
+    -- *** @Encoder@
+  , Encoder(..)
+
     -- ** The @DBType@ hierarchy
   , DBSemigroup(..)
   , DBMonoid(..)
@@ -355,6 +358,7 @@ module Rel8
   , run1
   , runMaybe
   , runVector
+  , prepared
 
     -- ** @SELECT@
   , select
@@ -383,6 +387,7 @@ module Rel8
     -- ** @WITH@
   , Statement
   , showStatement
+  , showPreparedStatement
 
     -- ** @CREATE VIEW@
   , createView
@@ -460,6 +465,7 @@ import Rel8.Statement
 import Rel8.Statement.Delete
 import Rel8.Statement.Insert
 import Rel8.Statement.OnConflict
+import Rel8.Statement.Prepared
 import Rel8.Statement.Returning
 import Rel8.Statement.Run
 import Rel8.Statement.Select
@@ -493,6 +499,7 @@ import Rel8.Type
 import Rel8.Type.Composite
 import Rel8.Type.Decoder
 import Rel8.Type.Eq
+import Rel8.Type.Encoder
 import Rel8.Type.Enum
 import Rel8.Type.Information
 import Rel8.Type.JSONBEncoded

src/Rel8/Expr/Aggregate.hs

@@ -80,7 +80,7 @@ import Rel8.Schema.Null ( Sql, Unnullify )
 import Rel8.Table.Opaleye (fromOrder, unpackspec)
 import Rel8.Table.Order (ascTable)
 import Rel8.Type ( DBType, typeInformation )
-import Rel8.Type.Array (arrayTypeName, encodeArrayElement)
+import Rel8.Type.Array (arrayTypeName, quoteArrayElement)
 import Rel8.Type.Eq ( DBEq )
 import Rel8.Type.Information (TypeInformation)
 import Rel8.Type.Num (DBFractional, DBNum)
@@ -451,7 +451,7 @@ slistAggExpr :: ()
   => TypeInformation (Unnullify a) -> Aggregator' fold (Expr a) (Expr [a])
 slistAggExpr info =
   unsafeMakeAggregator
-    (toColumn . encodeArrayElement info . toPrimExpr)
+    (toColumn . quoteArrayElement info . toPrimExpr)
     (fromPrimExpr . fromColumn)
     (Fallback (sempty info))
     Opaleye.arrayAgg
@@ -461,7 +461,7 @@ snonEmptyAggExpr :: ()
   => TypeInformation (Unnullify a) -> Aggregator1 (Expr a) (Expr (NonEmpty a))
 snonEmptyAggExpr info =
   unsafeMakeAggregator
-    (toColumn . encodeArrayElement info . toPrimExpr)
+    (toColumn . quoteArrayElement info . toPrimExpr)
     (fromPrimExpr . fromColumn)
     Empty
     Opaleye.arrayAgg

src/Rel8/Expr/Serialize.hs

@@ -1,3 +1,4 @@
+{-# language DisambiguateRecordFields #-}
 {-# language FlexibleContexts #-}
 {-# language NamedFieldPuns #-}
 {-# language TypeFamilies #-}
@@ -24,6 +25,7 @@ import Rel8.Expr.Opaleye ( scastExpr )
 import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )
 import Rel8.Type ( DBType, typeInformation )
 import Rel8.Type.Decoder (Decoder (..))
+import Rel8.Type.Encoder (Encoder (..))
 import Rel8.Type.Information ( TypeInformation(..) )
 
 
@@ -36,12 +38,12 @@ litExpr = slitExpr nullable typeInformation
 
 
 slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a
-slitExpr nullity info@TypeInformation {encode} =
+slitExpr nullity info@TypeInformation {encode = Encoder {quote}} =
   scastExpr info . Expr . encoder
   where
     encoder = case nullity of
-      Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
-      NotNull -> encode
+      Null -> maybe (Opaleye.ConstExpr Opaleye.NullLit) quote
+      NotNull -> quote
 
 
 sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a

src/Rel8/Generic/Construction/ADT.hs

@@ -77,10 +77,10 @@ type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a
 
 type NoConstructor :: Symbol -> Symbol -> ErrorMessage
 type NoConstructor datatype constructor =
-  ( 'Text "The type `" ':<>:
-    'Text datatype ':<>:
-    'Text "` has no constructor `" ':<>:
-    'Text constructor ':<>:
+  ( 'Text "The type `" ' :<>:
+    'Text datatype ' :<>:
+    'Text "` has no constructor `" ' :<>:
+    'Text constructor ' :<>:
     'Text "`."
   )
 

src/Rel8/Generic/Construction/Record.hs

@@ -63,8 +63,8 @@ type GConstructor :: (Type -> Type) -> Symbol
 type family GConstructor rep where
   GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name
   GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError (
-    'Text "`" ':<>:
-    'Text name ':<>:
+    'Text "`" ' :<>:
+    'Text name ' :<>:
     'Text "` does not appear to have exactly 1 constructor"
    )
 

src/Rel8/Statement/Prepared.hs

@@ -0,0 +1,87 @@
+{-# language AllowAmbiguousTypes #-}
+{-# language BlockArguments #-}
+{-# language FlexibleContexts #-}
+{-# language MonoLocalBinds #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+
+module Rel8.Statement.Prepared (
+  input,
+  prepared,
+) where
+
+-- base
+import Data.Functor.Const (Const (Const), getConst)
+import Data.Functor.Contravariant (contramap, (>$<))
+import Data.Functor.Identity (runIdentity)
+import Prelude
+
+-- hasql
+import qualified Hasql.Encoders as Hasql
+import qualified Hasql.Statement as Hasql
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import Rel8.Expr (Expr)
+import Rel8.Expr.Opaleye (fromPrimExpr, scastExpr)
+import Rel8.Schema.HTable (hfield, hspecs, htabulateA)
+import Rel8.Schema.Null (Nullity (Null, NotNull))
+import Rel8.Schema.Spec (Spec (..))
+import Rel8.Statement (Statement)
+import Rel8.Table (Table, fromColumns, toResult)
+import Rel8.Table.Serialize (Serializable)
+import Rel8.Type.Encoder (binary)
+import Rel8.Type.Information (encode)
+
+-- transformers
+import Control.Monad.Trans.State.Strict (evalState, state)
+
+
+{-| Given a 'Rel8.run' function that converts a 'Statement' to a
+'Hasql.Statement', return a 'Rel8.run'-like function which instead takes a
+/parameterized/ 'Statement' and converts it to a /preparable/
+'Hasql.Statement'.
+
+The parameters @i@ are sent to the database directly via PostgreSQL's binary
+format. For large amounts of data this can be significantly more efficient
+than embedding the values in the statement with 'Rel8.lit'.
+-}
+prepared :: forall a b i o.
+  Serializable a i =>
+  (Statement b -> Hasql.Statement () o) ->
+  (a -> Statement b) ->
+  Hasql.Statement i o
+prepared run mkStatement = Hasql.Statement sql (encoder @a) decode True
+  where
+    Hasql.Statement sql _ decode _ = run $ mkStatement input
+
+
+encoder :: forall a i. Serializable a i => Hasql.Params i
+encoder =
+  contramap (toResult @_ @a) $
+    getConst $
+      htabulateA \field ->
+        case hfield hspecs field of
+          Spec {nullity, info} -> Const $
+            runIdentity . (`hfield` field) >$<
+              case nullity of
+                Null -> Hasql.param $ Hasql.nullable build
+                NotNull -> Hasql.param $ Hasql.nonNullable build
+              where
+                build = binary (encode info)
+
+
+input :: Table Expr a => a
+input =
+  fromColumns $
+    flip (evalState @Word) 1 do
+      htabulateA \field -> do
+        n <- state (\n -> (n, n + 1))
+        pure
+          case hfield hspecs field of
+            Spec {info} ->
+              scastExpr info $ fromPrimExpr $
+                Opaleye.ConstExpr $ Opaleye.OtherLit $ '$' : show n

src/Rel8/Statement/Run.hs

@@ -57,16 +57,15 @@ runN = makeRun RowsAffected
 -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the
 -- result of the statement as a single row. If the statement returns a number
 -- of rows other than 1, a runtime exception is thrown.
-run1 :: Serializable exprs 
-  a=> Statement (Query exprs) -> Hasql.Statement () a
+run1 :: Serializable exprs a => Statement (Query exprs) -> Hasql.Statement () a
 run1 = makeRun Single
 
 
 -- | Convert a 'Statement' to a runnable 'Hasql.Statement', processing the
 -- result of the statement as 'Maybe' a single row. If the statement returns
 -- a number of rows other than 0 or 1, a runtime exception is thrown.
-runMaybe :: Serializable exprs 
-  a=> Statement (Query exprs) -> Hasql.Statement () (Maybe a)
+runMaybe :: Serializable exprs a
+  => Statement (Query exprs) -> Hasql.Statement () (Maybe a)
 runMaybe = makeRun Maybe
 
 

src/Rel8/Statement/SQL.hs

@@ -1,8 +1,11 @@
+{-# language FlexibleContexts #-}
+
 module Rel8.Statement.SQL
   ( showDelete
   , showInsert
   , showUpdate
   , showStatement
+  , showPreparedStatement
   )
 where
 
@@ -13,12 +16,15 @@ import Prelude
 import qualified Opaleye.Internal.Tag as Opaleye
 
 -- rel8
+import Rel8.Expr (Expr)
 import Rel8.Statement (Statement, ppDecodeStatement)
 import Rel8.Statement.Delete ( Delete, ppDelete )
 import Rel8.Statement.Insert ( Insert, ppInsert )
+import Rel8.Statement.Prepared (input)
 import Rel8.Statement.Rows (Rows (Void))
 import Rel8.Statement.Select (ppSelect)
 import Rel8.Statement.Update ( Update, ppUpdate )
+import Rel8.Table (Table)
 
 -- transformers
 import Control.Monad.Trans.State.Strict (evalState)
@@ -42,3 +48,9 @@ showUpdate = show . (`evalState` Opaleye.start) . ppUpdate
 -- | Convert a 'Statement' to a 'String' containing an SQL statement.
 showStatement :: Statement a -> String
 showStatement = show . fst . ppDecodeStatement ppSelect Void
+
+
+-- | Convert a parameterized 'Statement' to a 'String' containing an SQL
+-- statement.
+showPreparedStatement :: Table Expr i => (i -> Statement a) -> String
+showPreparedStatement = showStatement . ($ input)