Skip to content

Commit

Permalink
Safer placeholders
Browse files Browse the repository at this point in the history
Improvements from #70

- Wrap everything created from a `Record` with `WithPlaceholderOffsets`.
    - Which can be easily concatenated by `Applicative` combinators such as `<*>`.
    - Better solution than #70 (comment) and #70 (comment)
- (BREAKING CHANGE) Pass placeholders Record directly to `query'` etc.
    - Delete old (and unavailable anymore) placholders-related APIs: `placeholder` and `relation'` etc.

Left Tasks
====

- Some tests doesn't pass. Fix them.
- Avoid to use `toFlat` and `toAggregated` as much as possible: `ResultContext` should be adapted.
- Add tests for placeholders.
- You may want to refactor the design.
  • Loading branch information
Yuji Yamamoto committed May 17, 2019
1 parent 892bd17 commit 3c7b578
Show file tree
Hide file tree
Showing 62 changed files with 1,528 additions and 1,139 deletions.
10 changes: 5 additions & 5 deletions persistable-types-HDBC-pg/test/runTest.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()

Expand All @@ -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])]
Expand Down
6 changes: 3 additions & 3 deletions relational-query-HDBC/src/Database/HDBC/Query/TH.hs
Original file line number Diff line number Diff line change
Expand Up @@ -39,11 +39,11 @@ 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)
defaultConfig, Relation, relationalQuerySQL, QuerySuffix, detachPlaceholderOffsets, )
import qualified Database.Relational.TH as Relational

import Database.HDBC.Session (withConnectionIO)
Expand Down Expand Up @@ -171,7 +171,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
Expand Down
10 changes: 8 additions & 2 deletions relational-query-HDBC/src/Database/HDBC/Record/Insert.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
19 changes: 13 additions & 6 deletions relational-query-HDBC/src/Database/HDBC/Record/KeyUpdate.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand All @@ -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

Expand All @@ -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
Expand All @@ -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
Expand Down
27 changes: 17 additions & 10 deletions relational-query-HDBC/src/Database/HDBC/Record/Statement.hs
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,10 @@ module Database.HDBC.Record.Statement (
) where

import Control.Exception (bracket)
import Database.Relational (UntypeableNoFetch (untypeNoFetch))
import Database.Relational
(UntypeableNoFetch (untypeNoFetch),
sortByPlaceholderOffsets,
WithPlaceholderOffsets, SQLWithPlaceholderOffsets, detachPlaceholderOffsets, placeholderOffsets)
import Database.HDBC (IConnection, Statement, SqlValue)
import qualified Database.HDBC as HDBC

Expand All @@ -41,8 +44,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 =
Expand All @@ -64,15 +67,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)
Expand All @@ -85,15 +88,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 =
Expand All @@ -114,7 +117,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
Expand Down
3 changes: 3 additions & 0 deletions relational-query/relational-query.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
14 changes: 8 additions & 6 deletions relational-query/src/Database/Relational.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))
Expand All @@ -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)
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
Expand All @@ -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
Expand Down
Loading

0 comments on commit 3c7b578

Please sign in to comment.