Safer placeholders

persistable-types-HDBC-pg/test/runTest.hs

@@ -12,7 +12,7 @@ import Database.HDBC.Query.TH (makeRelationalRecord)
 import Data.PostgreSQL.NetworkAddress
   (Inet (..), Cidr (..), NetAddress (..),
    V4HostAddress (..), V6HostAddress (..))
-import Database.Relational (Relation, relation, value)
+import Database.Relational (Relation, relation, value, toFlat)
 
 import Database.HDBC.PostgreSQL.Persistable ()
 
@@ -30,25 +30,25 @@ $(makeRelationalRecord ''Foo)
 -- 192.168.0.1/24
 inet4 :: Relation () Inet
 inet4 =
-  relation . return . value . Inet $
+  relation . return . toFlat . value . Inet $
   NetAddress4 (V4HostAddress 192 168 0 1) 24
 
 -- 224.0.0.0/4
 cidr4 :: Relation () Cidr
 cidr4 =
-  relation . return . value . Cidr $
+  relation . return . toFlat . value . Cidr $
   NetAddress4 (V4HostAddress 224 0 0 0) 4
 
 -- fd00::1/8
 inet6 :: Relation () Inet
 inet6 =
-  relation . return . value . Inet $
+  relation . return . toFlat . value . Inet $
   NetAddress6 (V6HostAddress 0xfd00 0 0 0 0 0 0 1) 8
 
 -- ff00::/8
 cidr6 :: Relation () Cidr
 cidr6 =
-  relation . return . value . Cidr $
+  relation . return . toFlat . value . Cidr $
   NetAddress6 (V6HostAddress 0xff00 0 0 0 0 0 0 0) 8
 
 testSet :: [(String, String, [String])]

relational-query-HDBC/src/Database/HDBC/Query/TH.hs

@@ -39,11 +39,10 @@ import Language.Haskell.TH (Q, runIO, Name, TypeQ, Type (AppT, ConT), Dec)
 import Language.Haskell.TH.Lib.Extra (reportWarning, reportError)
 
 import Language.SQL.Keyword (Keyword)
-import Database.Record (ToSql, FromSql)
+import Database.Record (ToSql, FromSql, PersistableWidth)
 import Database.Record.TH (recordTemplate, defineSqlPersistableInstances)
 import Database.Relational
-  (Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning,
-   defaultConfig, Relation)
+  (Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning, defaultConfig, Relation, )
 import qualified Database.Relational.TH as Relational
 
 import Database.HDBC.Session (withConnectionIO)
@@ -171,7 +170,7 @@ defineTableFromDB :: IConnection conn
 defineTableFromDB connect driver tbl scm = tableAlongWithSchema connect driver tbl scm []
 
 -- | Verify composed 'Query' and inline it in compile type.
-inlineVerifiedQuery :: IConnection conn
+inlineVerifiedQuery :: (IConnection conn, PersistableWidth p)
                     => IO conn      -- ^ Connect action to system catalog database
                     -> Name         -- ^ Top-level variable name which has 'Relation' type
                     -> Relation p r -- ^ Object which has 'Relation' type

relational-query-HDBC/src/Database/HDBC/Record/Insert.hs

@@ -28,7 +28,9 @@ import Control.Monad (unless)
 import System.IO.Unsafe (unsafeInterleaveIO)
 import Database.HDBC (IConnection, SqlValue)
 
-import Database.Relational (Insert (..), untypeChunkInsert, chunkSizeOfInsert)
+import Database.Relational
+  (Insert (..), untypeChunkInsert, chunkSizeOfInsert,
+   detachPlaceholderOffsets, placeholderOffsets, sortByPlaceholderOffsets)
 import Database.Record (ToSql, fromRecord)
 
 import Database.HDBC.Record.Statement
@@ -80,7 +82,11 @@ mapInsert = mapNoFetch
 
 -- | Unsafely bind chunk of records.
 chunkBind :: ToSql SqlValue p => PreparedStatement [p] () -> [p] -> BoundStatement ()
-chunkBind q ps = BoundStatement { bound = untypePrepared q, params =  ps >>= fromRecord }
+chunkBind q ps = BoundStatement { bound = st, params = concatMap (sortByPlaceholderOffsets phs . fromRecord) ps }
+ where
+  stphs = untypePrepared q
+  st = detachPlaceholderOffsets stphs
+  phs = placeholderOffsets stphs
 
 withPrepareChunksInsert :: (IConnection conn, ToSql SqlValue a)
                         => conn

relational-query-HDBC/src/Database/HDBC/Record/KeyUpdate.hs

@@ -22,11 +22,13 @@ module Database.HDBC.Record.KeyUpdate (
   ) where
 
 import Control.Exception (bracket)
+import Data.Traversable (traverse)
 import Database.HDBC (IConnection, SqlValue, Statement)
 import qualified Database.HDBC as HDBC
 
 import Database.Relational
-  (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi)
+  (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi,
+   WithPlaceholderOffsets, placeholderOffsets, detachPlaceholderOffsets, sortByPlaceholderOffsets, )
 import qualified Database.Relational as DSL
 import Database.Record (ToSql)
 
@@ -41,15 +43,15 @@ data PreparedKeyUpdate p a =
     -- | Key to specify update target records.
     updateKey         :: Pi a p
     -- | Untyped prepared statement before executed.
-  , preparedKeyUpdate :: Statement
+  , preparedKeyUpdate :: WithPlaceholderOffsets Statement
   }
 
 -- | Typed prepare key-update operation.
 prepare :: IConnection conn
         => conn
         -> KeyUpdate p a
         -> IO (PreparedKeyUpdate p a)
-prepare conn ku = fmap (PreparedKeyUpdate key) . HDBC.prepare conn $ sql  where
+prepare conn ku = fmap (PreparedKeyUpdate key) . traverse (HDBC.prepare conn) $ sql where
   sql = untypeKeyUpdate ku
   key = DSL.updateKey ku
 
@@ -67,7 +69,7 @@ withPrepareKeyUpdate :: IConnection conn
                      -> (PreparedKeyUpdate p a -> IO b)
                      -> IO b
 withPrepareKeyUpdate conn ku body =
-    bracket (HDBC.prepare conn sql) HDBC.finish
+    bracket (traverse (HDBC.prepare conn) sql) (HDBC.finish . detachPlaceholderOffsets)
     $ body . PreparedKeyUpdate key
   where
     sql = untypeKeyUpdate ku
@@ -79,8 +81,13 @@ bindKeyUpdate :: ToSql SqlValue a
               -> a
               -> BoundStatement ()
 bindKeyUpdate pre a =
-  BoundStatement { bound = preparedKeyUpdate pre, params = updateValuesWithKey key a }
-  where key = updateKey pre
+  BoundStatement { bound = st, params = ps }
+  where
+    key = updateKey pre
+    stphs = preparedKeyUpdate pre 
+    st = detachPlaceholderOffsets stphs
+    phs = placeholderOffsets stphs
+    ps  = sortByPlaceholderOffsets phs $ updateValuesWithKey key a
 
 -- | Bind parameters, execute statement and get execution result.
 runPreparedKeyUpdate :: ToSql SqlValue a

relational-query-HDBC/src/Database/HDBC/Record/Statement.hs

@@ -31,7 +31,11 @@ module Database.HDBC.Record.Statement (
   ) where
 
 import Control.Exception (bracket)
-import Database.Relational (UntypeableNoFetch (untypeNoFetch))
+import Data.Traversable (traverse)
+import Database.Relational
+  (UntypeableNoFetch (untypeNoFetch),
+   sortByPlaceholderOffsets,
+   WithPlaceholderOffsets, SQLWithPlaceholderOffsets, detachPlaceholderOffsets, placeholderOffsets)
 import Database.HDBC (IConnection, Statement, SqlValue)
 import qualified Database.HDBC as HDBC
 
@@ -41,8 +45,8 @@ import Database.Record (ToSql, fromRecord)
 newtype PreparedStatement p a =
   PreparedStatement {
     -- | Untyped prepared statement before executed.
-    prepared :: Statement
-    }
+    prepared :: WithPlaceholderOffsets Statement
+  }
 
 -- | Typed prepared statement which has bound placeholder parameters.
 data BoundStatement a =
@@ -64,15 +68,15 @@ data ExecutedStatement a =
   }
 
 -- | Unsafely untype prepared statement.
-untypePrepared :: PreparedStatement p a -> Statement
+untypePrepared :: PreparedStatement p a -> WithPlaceholderOffsets Statement
 untypePrepared =  prepared
 
 -- | Run prepare and unsafely make Typed prepared statement.
 unsafePrepare :: IConnection conn
               => conn                       -- ^ Database connection
-              -> String                     -- ^ Raw SQL String
+              -> SQLWithPlaceholderOffsets  -- ^ Raw SQL String
               -> IO (PreparedStatement p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a'
-unsafePrepare conn = fmap PreparedStatement . HDBC.prepare conn
+unsafePrepare conn = fmap PreparedStatement . traverse (HDBC.prepare conn)
 
 -- | Generalized prepare inferred from 'UntypeableNoFetch' instance.
 prepareNoFetch :: (UntypeableNoFetch s, IConnection conn)
@@ -85,15 +89,15 @@ prepareNoFetch conn = unsafePrepare conn . untypeNoFetch
 --   PreparedStatement is released on closing connection,
 --   so connection pooling cases often cause resource leaks.
 finish :: PreparedStatement p a -> IO ()
-finish = HDBC.finish . prepared
+finish = HDBC.finish . detachPlaceholderOffsets . prepared
 
 -- | Bracketed prepare operation.
 --   Unsafely make Typed prepared statement.
 --   PreparedStatement is released on closing connection,
 --   so connection pooling cases often cause resource leaks.
 withUnsafePrepare :: IConnection conn
-                  => conn   -- ^ Database connection
-                  -> String -- ^ Raw SQL String
+                  => conn                      -- ^ Database connection
+                  -> SQLWithPlaceholderOffsets -- ^ Raw SQL String
                   -> (PreparedStatement p a -> IO b)
                   -> IO b
 withUnsafePrepare conn qs =
@@ -114,7 +118,11 @@ bind :: ToSql SqlValue p
      => PreparedStatement p a -- ^ Prepared query to bind to
      -> p                     -- ^ Parameter to bind
      -> BoundStatement a      -- ^ Result parameter bound statement
-bind q p = BoundStatement { bound = prepared q, params = fromRecord p }
+bind q p = BoundStatement { bound = st, params = sortByPlaceholderOffsets phs $ fromRecord p }
+ where
+  stphs = untypePrepared q
+  st = detachPlaceholderOffsets stphs
+  phs = placeholderOffsets stphs
 
 -- | Same as 'bind' except for argument is flipped.
 bindTo :: ToSql SqlValue p => p -> PreparedStatement p a -> BoundStatement a

relational-query/relational-query.cabal

@@ -59,6 +59,7 @@ library
                        Database.Relational.Monad.Trans.Restricting
                        Database.Relational.Monad.Trans.Join
                        Database.Relational.Monad.Trans.Config
+                       Database.Relational.Monad.Trans.ReadPlaceholders
                        Database.Relational.Monad.Trans.Assigning
                        Database.Relational.Monad.Type
                        Database.Relational.Monad.Simple
@@ -92,8 +93,10 @@ library
                        Database.Relational.SqlSyntax.Query
                        Database.Relational.SqlSyntax.Fold
                        Database.Relational.SqlSyntax.Updates
+                       Database.Relational.SqlSyntax.Placeholders
                        Database.Relational.Monad.Trans.JoinState
                        Database.Relational.Monad.Trans.Qualify
+                       Database.Relational.Monad.Trans.ReadPlaceholders.Type
                        Database.Relational.InternalTH.Base
 
                        -- for GHC version equal or more than 8.0
@@ -116,6 +119,8 @@ library
                        , persistable-record >= 0.6
   if impl(ghc == 7.4.*)
     build-depends:       ghc-prim == 0.2.*
+  if impl(ghc < 8)
+    build-depends:       semigroups
 
   hs-source-dirs:      src
   ghc-options:         -Wall -fsimpl-tick-factor=200

relational-query/src/Database/Relational.hs

@@ -24,21 +24,21 @@ module Database.Relational (
   module Database.Relational.Monad.Class,
   module Database.Relational.Monad.Trans.Ordering,
   module Database.Relational.Monad.Trans.Aggregating,
-  module Database.Relational.Monad.Trans.Assigning,
   module Database.Relational.Monad.Type,
   module Database.Relational.Monad.Simple,
   module Database.Relational.Monad.Aggregate,
   module Database.Relational.Monad.Restrict,
   module Database.Relational.Monad.Unique,
   module Database.Relational.Monad.Assign,
   module Database.Relational.Monad.Register,
+  module Database.Relational.Monad.Trans.ReadPlaceholders,
   module Database.Relational.Relation,
   module Database.Relational.Set,
   module Database.Relational.Sequence,
   module Database.Relational.Scalar,
   module Database.Relational.Type,
   module Database.Relational.Effect,
-  module Database.Relational.Derives
+  module Database.Relational.Derives,
   ) where
 
 import Database.Relational.Table (Table, TableDerivable (..))
@@ -55,8 +55,10 @@ import Database.Relational.Context
 import Database.Relational.Config
 import Database.Relational.SqlSyntax
   (Order (..), Nulls (..), AggregateKey, Record, Predicate, PI,
-   SubQuery, unitSQL, queryWidth, )
-import Database.Relational.Record (RecordList, list)
+   PlaceholderOffsets, WithPlaceholderOffsets, SQLWithPlaceholderOffsets, SQLWithPlaceholderOffsets',
+   SubQuery, unitSQL, queryWidth,
+   withPlaceholderOffsets, attachEmptyPlaceholderOffsets, detachPlaceholderOffsets, sortByPlaceholderOffsets, placeholderOffsets, )
+import Database.Relational.Record (RecordList, list, pempty, toFlat, toAggregated)
 import Database.Relational.ProjectableClass
 import Database.Relational.Projectable
 import Database.Relational.TupleInstances
@@ -72,14 +74,14 @@ import Database.Relational.Monad.Trans.Ordering
   (Orderings, orderBy', orderBy, asc, desc)
 import Database.Relational.Monad.Trans.Aggregating
   (key, key', set, bkey, rollup, cube, groupingSets)
-import Database.Relational.Monad.Trans.Assigning (assignTo, (<-#))
+import Database.Relational.Monad.Trans.ReadPlaceholders
 import Database.Relational.Monad.Type
 import Database.Relational.Monad.Simple (QuerySimple, SimpleQuery)
 import Database.Relational.Monad.Aggregate
   (QueryAggregate, AggregatedQuery, Window, over)
 import Database.Relational.Monad.Restrict (Restrict)
 import Database.Relational.Monad.Unique (QueryUnique)
-import Database.Relational.Monad.Assign (Assign)
+import Database.Relational.Monad.Assign (Assign, assignTo, (<-#))
 import Database.Relational.Monad.Register (Register)
 import Database.Relational.Relation
 import Database.Relational.Set