7fe976d · squeal · git.iko.soy

git.iko.soy/squeal

Merge pull request #25 from echatav/chain

chain statement executions

commit7fe976de592daf00c516ac99f95d698c24c6aa64 authorEitan Chatav <eitan.chatav@gmail.com> dateWed 5 Jul 2017, 15:48 (9 years ago) parent71b64ef 0eafb54

5 files changed+108−94

compare with dev

unifiedsplit

squeel-postgresql/exe/Example.hs+27−34 squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+26−21 squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+8−7 squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+41−26 squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+6−6

squeel-postgresql/exe/Example.hs+27−34

@@ -4,12 +4,12 @@

44 , OverloadedLabels

55 , OverloadedStrings

66 , ScopedTypeVariables

7+ , TypeApplications

78 , TypeOperators

89#-}

910

1011module Main (main) where

1112

12−import Control.Category ((>>>))

1313import Control.Monad.Base

1414import Control.Monad.Except

1515import Control.Monad.Trans.Maybe

@@ -28,45 +28,38 @@ main = do

2828 "host=localhost port=5432 dbname=exampledb"

2929 Char8.putStrLn $ "connecting to " <> connectionString

3030 connection0 <- connectdb connectionString

31− Char8.putStrLn "creating tables"

32− connection1 <- flip execPQ connection0 $ pqExec $

33− createTable #students

31+ Char8.putStrLn "setting up database"

32+ connection1 <- flip execPQ connection0 $

33+ pqExec ( createTable #students

3434 ( (text & notNull) `As` #name

35− :* Nil )

36− >>>

37− createTable #table1

35+ :* Nil ) )

36+ &>> createTable #table1

3837 ( (int4 & notNull) `As` #col1

3938 :* (int4 & notNull) `As` #col2

4039 :* Nil )

40+ &>> insertInto #table1 ( 1 `As` #col1 :* 2 `As` #col2 :* Nil )

41+ &>> insertInto #table1 ( 3 `As` #col1 :* 4 `As` #col2 :* Nil )

42+ Char8.putStrLn "querying"

4143 connection2 <- flip execPQ connection1 $ do

42− _insertTable1Result <- pqExec $

43− insertInto #table1 ( 1 `As` #col1 :* 2 `As` #col2 :* Nil )

44− >>>

45− insertInto #table1 ( 3 `As` #col1 :* 4 `As` #col2 :* Nil )

46− Just selectTable1Result <- flip pqExecParams Nil $

47− (select $ starFrom #table1 :: Statement '[] Columns Tables Tables)

48− Just (Right value00) <- runMaybeT . runExceptT . flip runValue selectTable1Result $

49− getValue (RowNumber 0) colNum0

50− Just (Right value01) <- runMaybeT . runExceptT . flip runValue selectTable1Result $

51− getValue (RowNumber 0) colNum1

52− Just (Right value10) <- runMaybeT . runExceptT . flip runValue selectTable1Result $

53− getValue (RowNumber 1) colNum0

54− Just (Right value11) <- runMaybeT . runExceptT . flip runValue selectTable1Result $

55− getValue (RowNumber 1) colNum1

56− Just (Right row0) <- runMaybeT . runExceptT . flip runValue selectTable1Result $

57− getRow (RowNumber 0)

58− Just (Right row1) <- runMaybeT . runExceptT . flip runValue selectTable1Result $

59− getRow (RowNumber 1)

60− liftBase $ do

61− print (value00 :: Int32)

62− print (value01 :: Int32)

63− print (value10 :: Int32)

64− print (value11 :: Int32)

65− print (row0 :: NP I '[Int32,Int32])

66− print (row1 :: NP I '[Int32,Int32])

67− connection3 :: Connection '[] <- flip execPQ connection2 $ pqExec $

44+ Just result <- pqExecNil $ select $ starFrom #table1

45+ runMaybeT . runExceptT . flip runValue result $ do

46+ value00 <- getValue (RowNumber 0) (columnNumber @0)

47+ value01 <- getValue (RowNumber 0) (columnNumber @1)

48+ value10 <- getValue (RowNumber 1) (columnNumber @0)

49+ value11 <- getValue (RowNumber 1) (columnNumber @1)

50+ row0 <- getRow (RowNumber 0)

51+ row1 <- getRow (RowNumber 1)

52+ liftBase $ do

53+ print (value00 :: Int32)

54+ print (value01 :: Int32)

55+ print (value10 :: Int32)

56+ print (value11 :: Int32)

57+ print (row0 :: NP I '[Int32,Int32])

58+ print (row1 :: NP I '[Int32,Int32])

59+ Char8.putStrLn "tearing down database"

60+ connection3 :: Connection '[] <- flip execPQ connection2 $ pqExec

6861 (dropTable #table1 :: Statement '[] '[] Tables '["students" ::: StudentsColumns])

69− >>> dropTable #students

62+ &>> dropTable #students

7063 finish connection3

7164

7265type Columns =

squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+26−21

@@ -73,7 +73,7 @@ class MonadPQ pq where

7373 -> pq db0 db1 io (Maybe (Result '[]))

7474

7575 pqExecParams

76− :: (MonadBase IO io, ToOids ps, AllZip HasEncoding ps xs, All Top ps)

76+ :: (MonadBase IO io, ToOids ps, AllZip HasEncoding ps xs)

7777 => Statement ps ys db0 db1

7878 -> NP I xs

7979 -> pq db0 db1 io (Maybe (Result ys))

@@ -82,14 +82,27 @@ class MonadPQ pq where

8282 :: (MonadBase IO io, ToOids ps)

8383 => ByteString

8484 -> Statement ps xs db0 db1

85− -> pq db0 db1 io (Maybe (Result []), PreparedStatement ps xs db0 db1)

85+ -> pq db0 db1 io (Maybe (Result '[]), PreparedStatement ps xs db0 db1)

8686

8787 pqExecPrepared

88− :: (MonadBase IO io, AllZip HasEncoding ps xs, All Top ps)

88+ :: (MonadBase IO io, AllZip HasEncoding ps xs)

8989 => PreparedStatement ps ys db0 db1

9090 -> NP I xs

9191 -> pq db0 db1 io (Maybe (Result ys))

9292

93+(&>>)

94+ :: (MonadPQ pq, MonadBase IO io)

95+ => pq db0 db1 io (Maybe (Result '[]))

96+ -> Statement '[] '[] db1 db2

97+ -> pq db0 db2 io (Maybe (Result '[]))

98+pq1 &>> statement2 = pqBind (\ _ -> pqExec statement2) pq1

99+

100+pqExecNil

101+ :: (MonadPQ pq, MonadBase IO io)

102+ => Statement '[] ys db0 db1

103+ -> pq db0 db1 io (Maybe (Result ys))

104+pqExecNil statement = pqExecParams statement Nil

105+

93106instance MonadPQ PQ where

94107

95108 pqAp (PQ f) (PQ x) = PQ $ \ conn -> do

@@ -177,32 +190,24 @@ withConnection

177190withConnection connString action =

178191 bracket (connectdb connString) finish action

179192

180−newtype Result xs = Result { unResult :: LibPQ.Result }

193+newtype Result (xs :: [(Symbol,ColumnType)])

194+ = Result { unResult :: LibPQ.Result }

181195

182196newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }

183197

184−newtype ColumnNumber cs c = ColumnNumber { unColumnNumber :: LibPQ.Column }

198+newtype ColumnNumber n cs c =

199+ UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }

185200

186−class KnownNat n => HasColumnNumber (n :: Nat) columns column

201+class KnownNat n => HasColumnNumber n columns column

187202 | n columns -> column where

188− colNum :: Proxy# n -> ColumnNumber columns column

189− colNum p = ColumnNumber . fromIntegral $ natVal' p

203+ columnNumber :: ColumnNumber n columns column

204+ columnNumber =

205+ UnsafeColumnNumber . fromIntegral $ natVal' (proxy# :: Proxy# n)

190206instance {-# OVERLAPPING #-} HasColumnNumber 0 (column1:columns) column1

191207instance {-# OVERLAPPABLE #-}

192208 (KnownNat n, HasColumnNumber (n-1) columns column)

193209 => HasColumnNumber n (column' : columns) column

194210

195−colNum0 :: ColumnNumber (c0:cs) c0

196−colNum0 = colNum (proxy# :: Proxy# 0)

197−colNum1 :: ColumnNumber (c0:c1:cs) c1

198−colNum1 = colNum (proxy# :: Proxy# 1)

199−colNum2 :: ColumnNumber (c0:c1:c2:cs) c2

200−colNum2 = colNum (proxy# :: Proxy# 2)

201−colNum3 :: ColumnNumber (c0:c1:c2:c3:cs) c3

202−colNum3 = colNum (proxy# :: Proxy# 3)

203−colNum4 :: ColumnNumber (c0:c1:c2:c3:c4:cs) c4

204−colNum4 = colNum (proxy# :: Proxy# 4)

205−

206211newtype Value pgs m x = Value { runValue :: Result pgs -> m x }

207212 deriving (Functor)

208213instance Applicative m => Applicative (Value pgs m) where

@@ -221,9 +226,9 @@ instance MonadBase b m => MonadBase b (Value pgs m) where

221226getValue

222227 :: (HasDecoding pg x, MonadBase IO io)

223228 => RowNumber

224− -> ColumnNumber pgs pg

229+ -> ColumnNumber n pgs pg

225230 -> Value pgs (ExceptT Text (MaybeT io)) x

226−getValue (RowNumber r) (ColumnNumber c :: ColumnNumber pgs pg) =

231+getValue (RowNumber r) (UnsafeColumnNumber c :: ColumnNumber n pgs pg) =

227232 Value $ \ (Result result) -> do

228233 maybeBytestring <- liftBase $ LibPQ.getvalue result r c

229234 case maybeBytestring of

squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+8−7

@@ -17,7 +17,7 @@ module Squeel.PostgreSQL.Schema

1717 ( PGType (..)

1818 , ToOid (..)

1919 , ToOids (..)

20− , PGNum

20+ , PGNum (..)

2121 , PGFractional

2222 , PGFloating

2323 , (:::)

@@ -82,12 +82,13 @@ instance (ToOid pg, ToOids pgs) => ToOids (pg ': pgs) where

8282 toOids _ = toOid (proxy# :: Proxy# pg) : toOids (proxy# :: Proxy# pgs)

8383

8484class PGNum (ty :: PGType) where

85−instance PGNum 'PGInt2

86−instance PGNum 'PGInt4

87−instance PGNum 'PGInt8

88−instance PGNum 'PGNumeric

89−instance PGNum 'PGFloat4

90−instance PGNum 'PGFloat8

85+ decimal :: proxy ty -> Bool

86+instance PGNum 'PGInt2 where decimal _ = False

87+instance PGNum 'PGInt4 where decimal _ = False

88+instance PGNum 'PGInt8 where decimal _ = False

89+instance PGNum 'PGNumeric where decimal _ = True

90+instance PGNum 'PGFloat4 where decimal _ = True

91+instance PGNum 'PGFloat8 where decimal _ = True

9192

9293class PGNum ty => PGFractional (ty :: PGType) where

9394instance PGFractional 'PGNumeric

squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+41−26

@@ -8,6 +8,7 @@

88 , MagicHash

99 , OverloadedStrings

1010 , ScopedTypeVariables

11+ , TypeApplications

1112 , TypeFamilies

1213 , TypeOperators

1314 , UndecidableInstances

@@ -15,7 +16,6 @@

1516

1617module Squeel.PostgreSQL.Statement where

1718

18−import Control.Category

1919import Data.Boolean

2020import Data.Boolean.Numbers

2121import Data.ByteString (ByteString)

@@ -27,7 +27,7 @@ import Generics.SOP

2727import GHC.Exts

2828import GHC.OverloadedLabels

2929import GHC.TypeLits

30−import Prelude hiding (id,(.),RealFrac(..))

30+import Prelude hiding (RealFrac(..))

3131

3232import qualified Data.ByteString as ByteString

3333

@@ -134,7 +134,11 @@ instance PGNum ty

134134 (*) = unsafeBinaryOp "*"

135135 abs = unsafeFunction "abs"

136136 signum = unsafeFunction "sign"

137− fromInteger = UnsafeExpression . (<> ".") . fromString . show

137+ fromInteger

138+ = UnsafeExpression

139+ . (<> if decimal (Proxy :: Proxy ty) then "." else "")

140+ . fromString

141+ . show

138142

139143instance PGFractional ty

140144 => Fractional (Expression params tables ('Required (nullity ty))) where

@@ -334,11 +338,6 @@ newtype Statement

334338 = UnsafeStatement { renderStatement :: ByteString }

335339 deriving (Show,Eq)

336340

337−instance Category (Statement '[] '[]) where

338− id = UnsafeStatement ";"

339− statement2 . statement1 = UnsafeStatement $

340− renderStatement statement1 <> " " <> renderStatement statement2

341−

342341newtype PreparedStatement

343342 (params :: [ColumnType])

344343 (columns :: [(Symbol,ColumnType)])

@@ -615,53 +614,53 @@ serial8 :: TypeExpression ('Optional ('NotNull 'PGInt8))

615614serial8 = UnsafeTypeExpression "serial8"

616615bigserial :: TypeExpression ('Optional ('NotNull 'PGInt8))

617616bigserial = UnsafeTypeExpression "bigserial"

618−money :: TypeExpression ('Optional ('NotNull 'PGMoney))

617+money :: TypeExpression ('Required ('Null 'PGMoney))

619618money = UnsafeTypeExpression "money"

620619text :: TypeExpression ('Required ('Null 'PGText))

621620text = UnsafeTypeExpression "text"

622621char

623622 :: KnownNat n

624623 => proxy n

625− -> TypeExpression ('Optional ('NotNull ('PGChar n)))

624+ -> TypeExpression ('Required ('Null ('PGChar n)))

626625char (_ :: proxy n) = UnsafeTypeExpression $

627626 "char(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"

628627character

629628 :: KnownNat n

630629 => proxy n

631− -> TypeExpression ('Optional ('NotNull ('PGChar n)))

630+ -> TypeExpression ('Required ('Null ('PGChar n)))

632631character (_ :: proxy n) = UnsafeTypeExpression $

633632 "character(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"

634633varchar

635634 :: KnownNat n

636635 => proxy n

637− -> TypeExpression ('Optional ('NotNull ('PGVarChar n)))

636+ -> TypeExpression ('Required ('Null ('PGVarChar n)))

638637varchar (_ :: proxy n) = UnsafeTypeExpression $

639638 "varchar(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"

640639characterVarying

641640 :: KnownNat n

642641 => proxy n

643− -> TypeExpression ('Optional ('NotNull ('PGVarChar n)))

642+ -> TypeExpression ('Required ('Null ('PGVarChar n)))

644643characterVarying (_ :: proxy n) = UnsafeTypeExpression $

645644 "character varying(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"

646−bytea :: TypeExpression ('Optional ('NotNull ('PGBytea)))

645+bytea :: TypeExpression ('Required ('Null ('PGBytea)))

647646bytea = UnsafeTypeExpression "bytea"

648−timestamp :: TypeExpression ('Optional ('NotNull ('PGTimestamp)))

647+timestamp :: TypeExpression ('Required ('Null ('PGTimestamp)))

649648timestamp = UnsafeTypeExpression "timestamp"

650−timestampWithTimeZone :: TypeExpression ('Optional ('NotNull ('PGTimestampTZ)))

649+timestampWithTimeZone :: TypeExpression ('Required ('Null ('PGTimestampTZ)))

651650timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

652−date :: TypeExpression ('Optional ('NotNull ('PGDate)))

651+date :: TypeExpression ('Required ('Null ('PGDate)))

653652date = UnsafeTypeExpression "date"

654−time :: TypeExpression ('Optional ('NotNull ('PGTime)))

653+time :: TypeExpression ('Required ('Null ('PGTime)))

655654time = UnsafeTypeExpression "time"

656−timeWithTimeZone :: TypeExpression ('Optional ('NotNull ('PGTimeTZ)))

655+timeWithTimeZone :: TypeExpression ('Required ('Null ('PGTimeTZ)))

657656timeWithTimeZone = UnsafeTypeExpression "time with time zone"

658−interval :: TypeExpression ('Optional ('NotNull ('PGInterval)))

657+interval :: TypeExpression ('Required ('Null ('PGInterval)))

659658interval = UnsafeTypeExpression "interval"

660−uuid :: TypeExpression ('Optional ('NotNull ('PGUuid)))

659+uuid :: TypeExpression ('Required ('Null ('PGUuid)))

661660uuid = UnsafeTypeExpression "uuid"

662−json :: TypeExpression ('Optional ('NotNull ('PGJson)))

661+json :: TypeExpression ('Required ('Null ('PGJson)))

663662json = UnsafeTypeExpression "json"

664−jsonb :: TypeExpression ('Optional ('NotNull ('PGJsonb)))

663+jsonb :: TypeExpression ('Required ('Null ('PGJsonb)))

665664jsonb = UnsafeTypeExpression "jsonb"

666665

667666notNull

@@ -677,11 +676,27 @@ default_ x ty = UnsafeTypeExpression $

677676

678677class PGTyped (ty :: PGType) where

679678 pgtype :: TypeExpression ('Required ('Null ty))

679+instance PGTyped 'PGBool where pgtype = bool

680680instance PGTyped 'PGInt2 where pgtype = int2

681681instance PGTyped 'PGInt4 where pgtype = int4

682682instance PGTyped 'PGInt8 where pgtype = int8

683−instance PGTyped 'PGBool where pgtype = bool

683+instance PGTyped 'PGNumeric where pgtype = numeric

684+instance PGTyped 'PGFloat4 where pgtype = float4

685+instance PGTyped 'PGFloat8 where pgtype = float8

686+instance PGTyped 'PGMoney where pgtype = money

684687instance PGTyped 'PGText where pgtype = text

688+instance KnownNat n => PGTyped ('PGChar n) where pgtype = char (Proxy @n)

689+instance KnownNat n => PGTyped ('PGVarChar n) where pgtype = varchar (Proxy @n)

690+instance PGTyped 'PGBytea where pgtype = bytea

691+instance PGTyped 'PGTimestamp where pgtype = timestamp

692+instance PGTyped 'PGTimestampTZ where pgtype = timestampWithTimeZone

693+instance PGTyped 'PGDate where pgtype = date

694+instance PGTyped 'PGTime where pgtype = time

695+instance PGTyped 'PGTimeTZ where pgtype = timeWithTimeZone

696+instance PGTyped 'PGInterval where pgtype = interval

697+instance PGTyped 'PGUuid where pgtype = uuid

698+instance PGTyped 'PGJson where pgtype = json

699+instance PGTyped 'PGJsonb where pgtype = jsonb

685700

686701createTable

687702 :: (KnownSymbol table, SListI columns)

@@ -711,8 +726,8 @@ class KnownSymbol table => DropTable table schema0 schema1

711726 dropTable (Alias table) = UnsafeStatement $

712727 "DROP TABLE " <> fromString (symbolVal' table) <> ";"

713728instance {-# OVERLAPPING #-}

714− (KnownSymbol table, table ~ table')

715− => DropTable table ((table' ::: columns) ': schema) schema

729+ (KnownSymbol table, table ~ table', schema ~ schema')

730+ => DropTable table ((table' ::: columns) ': schema) schema'

716731instance {-# OVERLAPPABLE #-}

717732 DropTable table schema0 schema1

718733 => DropTable table (table' ': schema0) (table' ': schema1)

squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+6−6

@@ -47,13 +47,13 @@ spec = do

4747 let

4848 statement :: Statement '[] Columns Tables Tables

4949 statement = select $ starFrom (#table1 & limit 1)

50− statement `shouldRenderAs` "SELECT * FROM table1 AS table1 LIMIT 1.;"

50+ statement `shouldRenderAs` "SELECT * FROM table1 AS table1 LIMIT 1;"

5151 it "should use the minimum of given LIMITs" $ do

5252 let

5353 statement :: Statement '[] Columns Tables Tables

5454 statement = select $ starFrom (#table1 & limit 1 & limit 2)

5555 statement `shouldRenderAs`

56− "SELECT * FROM table1 AS table1 LIMIT CASE WHEN (1. <= 2.) THEN 1. ELSE 2. END;"

56+ "SELECT * FROM table1 AS table1 LIMIT CASE WHEN (1 <= 2) THEN 1 ELSE 2 END;"

5757 it "should render parameters using $ signs" $ do

5858 let

5959 statement :: Statement '[ 'Required ('NotNull 'PGInt8)] Columns Tables Tables

@@ -63,18 +63,18 @@ spec = do

6363 let

6464 statement :: Statement '[] Columns Tables Tables

6565 statement = select $ starFrom (#table1 & offset 1)

66− statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET 1.;"

66+ statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET 1;"

6767 it "should use the sum of given OFFSETs" $ do

6868 let

6969 statement :: Statement '[] Columns Tables Tables

7070 statement = select $ starFrom (#table1 & offset 1 & offset 2)

71− statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET (1. + 2.);"

71+ statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET (1 + 2);"

7272 it "correctly render simple INSERTs" $ do

7373 let

7474 statement :: Statement '[] '[] Tables Tables

7575 statement = insertInto #table1 $ 2 `As` #col1 :* 4 `As` #col2 :* Nil

7676 statement `shouldRenderAs`

77− "INSERT INTO table1 (col1, col2) VALUES (2., 4.);"

77+ "INSERT INTO table1 (col1, col2) VALUES (2, 4);"

7878 it "should be safe against SQL injection in literal text" $ do

7979 let

8080 statement :: Statement '[] '[] StudentsTable StudentsTable

@@ -145,7 +145,7 @@ spec = do

145145 :* (int8 & notNull & default_ 8) `As` #col3

146146 :* Nil)

147147 `shouldRenderAs`

148− "CREATE TABLE table2 (col1 serial, col2 text, col3 int8 NOT NULL DEFAULT 8.);"

148+ "CREATE TABLE table2 (col1 serial, col2 text, col3 int8 NOT NULL DEFAULT 8);"

149149 it "should render DROP TABLE statements" $ do

150150 let

151151 statement :: Statement '[] '[] Tables '[]