230810f · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

Merge pull request #18 from echatav/create-drop

230810fEitan Chatav9 years ago

squeel-postgresql/squeel-postgresql.cabal+2−2

compare with dev

unifiedsplit

@@ -14,7 +14,7 @@ library

14 hs-source-dirs: src

15 exposed-modules:

16 Squeel.PostgreSQL.PQ

17− Squeel.PostgreSQL.Query

17+ Squeel.PostgreSQL.Statement

18 Squeel.PostgreSQL.Schema

19 Squeel.PostgreSQL.Value

20 default-language: Haskell2010

@@ -43,7 +43,7 @@ test-suite squeel-postgresql-test

43 ghc-options: -Wall -Werror

44 main-is: Spec.hs

45 other-modules:

46− Squeel.PostgreSQL.QuerySpec

46+ Squeel.PostgreSQL.StatementSpec

47 Squeel.PostgreSQL.ValueSpec

48 build-depends:

49 base

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

@@ -28,7 +28,7 @@ import GHC.TypeLits

29import qualified Database.PostgreSQL.LibPQ as LibPQ

31−import Squeel.PostgreSQL.Query

31+import Squeel.PostgreSQL.Statement

32import Squeel.PostgreSQL.Value

33import Squeel.PostgreSQL.Schema

@@ -64,24 +64,24 @@ class MonadPQ pq where

65 pqExec

66 :: MonadBase IO io

67− => Query '[] db0 db1 xs

67+ => Statement '[] db0 db1 xs

68 -> pq db0 db1 io (Maybe (Result xs))

70 pqExecParams

71 :: (MonadBase IO io, ToOids ps, ToValues xs ps)

72− => Query ps db0 db1 ys

72+ => Statement ps db0 db1 ys

73 -> Rec Identity xs

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

76 pqPrepare

77 :: (MonadBase IO io, ToOids ps)

78 => ByteString

79− -> Query ps db0 db1 xs

79+ -> Statement ps db0 db1 xs

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

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

82 pqExecPrepared

83 :: (MonadBase IO io, ToValues xs ps)

84− => PreparedQuery ps db0 db1 ys

84+ => PreparedStatement ps db0 db1 ys

85 -> Rec Identity xs

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

@@ -96,11 +96,11 @@ instance MonadPQ PQ where

96 (x', conn') <- x conn

97 runPQ (f x') conn'

99− pqExec (UnsafeQuery q) = PQ $ \ (Connection conn) -> do

99+ pqExec (UnsafeStatement q) = PQ $ \ (Connection conn) -> do

100 result <- liftBase $ LibPQ.exec conn q

101 return (Result <$> result, Connection conn)

102

103− pqExecParams (UnsafeQuery q :: Query ps db0 db1 ys) params =

103+ pqExecParams (UnsafeStatement q :: Statement ps db0 db1 ys) params =

104 PQ $ \ (Connection conn) -> do

105 let

106 params' =

@@ -113,16 +113,16 @@ instance MonadPQ PQ where

113 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

114 return (Result <$> result, Connection conn)

115

116− pqPrepare statementName (UnsafeQuery q :: Query ps db0 db1 ys) =

116+ pqPrepare statementName (UnsafeStatement q :: Statement ps db0 db1 ys) =

117 PQ $ \ (Connection conn) -> do

118 result <- liftBase $

119 LibPQ.prepare conn statementName q (Just (toOids (proxy# :: Proxy# ps)))

120 return

121 ( ( Result <$> result

122− , UnsafePreparedQuery statementName

122+ , UnsafePreparedStatement statementName

123 ) , Connection conn )

124

125− pqExecPrepared (q :: PreparedQuery ps db0 db1 ys) params =

125+ pqExecPrepared (q :: PreparedStatement ps db0 db1 ys) params =

126 PQ $ \ (Connection conn) -> do

127 let

128 params' =

@@ -130,7 +130,7 @@ instance MonadPQ PQ where

130 | param' <- toValues (proxy# :: Proxy# ps) params

131 ]

132 result <- liftBase $

133− LibPQ.execPrepared conn (renderPreparedQuery q) params' LibPQ.Binary

133+ LibPQ.execPrepared conn (renderPreparedStatement q) params' LibPQ.Binary

134 return (Result <$> result, Connection conn)

135

136instance Monad m => Applicative (PQ db db m) where

squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+58

@@ -1,5 +1,6 @@

1{-# LANGUAGE

2 DataKinds

3+ , FlexibleContexts

3 , FlexibleInstances

4 , FlexibleInstances

4 , GADTs

5 , GADTs

5 , MagicHash

6 , MagicHash

@@ -19,6 +20,8 @@ module Squeel.PostgreSQL.Schema

19 , (:::)

20 , (:::)

20 , Alias (Alias)

21 , Alias (Alias)

21 , Aliased (As)

22 , Aliased (As)

23+ , KnownPGType (..)

24+ , KnownColumns (..)

22 , renderAliased

25 , renderAliased

23 , module GHC.OverloadedLabels

26 , module GHC.OverloadedLabels

24 , module GHC.TypeLits

27 , module GHC.TypeLits

@@ -97,3 +100,58 @@ renderAliased

97 -> ByteString

100 -> ByteString

98renderAliased render (expression `As` Alias alias) =

101renderAliased render (expression `As` Alias alias) =

99 render expression <> " AS " <> fromString (symbolVal' alias)

102 render expression <> " AS " <> fromString (symbolVal' alias)

103+

104+class KnownPGType (ty :: PGType) where

105+ renderPGType :: Proxy# ty -> ByteString

106+instance KnownPGType 'PGBool where renderPGType _ = "bool"

107+instance KnownPGType 'PGInt2 where renderPGType _ = "int2"

108+instance KnownPGType 'PGInt4 where renderPGType _ = "int4"

109+instance KnownPGType 'PGInt8 where renderPGType _ = "int8"

110+instance KnownPGType 'PGNumeric where renderPGType _ = "numeric"

111+instance KnownPGType 'PGFloat4 where renderPGType _ = "float4"

112+instance KnownPGType 'PGFloat8 where renderPGType _ = "float8"

113+instance KnownPGType 'PGSerial2 where renderPGType _ = "serial2"

114+instance KnownPGType 'PGSerial4 where renderPGType _ = "serial4"

115+instance KnownPGType 'PGSerial8 where renderPGType _ = "serial8"

116+instance KnownPGType 'PGMoney where renderPGType _ = "money"

117+instance KnownNat n => KnownPGType ('PGChar n) where

118+ renderPGType _ = "char("

119+ <> fromString (show (natVal' (proxy# :: Proxy# n)))

120+ <> ")"

121+instance KnownNat n => KnownPGType ('PGVarChar n) where

122+ renderPGType _ = "varchar("

123+ <> fromString (show (natVal' (proxy# :: Proxy# n)))

124+ <> ")"

125+instance KnownPGType 'PGText where renderPGType _ = "text"

126+instance KnownPGType 'PGBytea where renderPGType _ = "bytea"

127+instance KnownPGType 'PGTimestamp where renderPGType _ = "timestamp"

128+instance KnownPGType 'PGTimestampTZ where renderPGType _ = "timestampTZ"

129+instance KnownPGType 'PGDate where renderPGType _ = "date"

130+instance KnownPGType 'PGTime where renderPGType _ = "time"

131+instance KnownPGType 'PGTimeTZ where renderPGType _ = "timeTZ"

132+instance KnownPGType 'PGInterval where renderPGType _ = "interval"

133+instance KnownPGType 'PGUuid where renderPGType _ = "uuid"

134+instance KnownPGType 'PGJson where renderPGType _ = "json"

135+instance KnownPGType 'PGJsonb where renderPGType _ = "jsonb"

136+

137+class KnownColumns (columns :: [(Symbol,PGType)]) where

138+ renderColumns :: Proxy# columns -> ByteString

139+instance

140+ ( KnownSymbol column

141+ , KnownPGType ty

142+ ) => KnownColumns '[column ::: ty] where

143+ renderColumns _ =

144+ fromString (symbolVal' (proxy# :: Proxy# column))

145+ <> " "

146+ <> renderPGType (proxy# :: Proxy# ty)

147+instance

148+ ( KnownSymbol column

149+ , KnownPGType ty

150+ , KnownColumns (columnsHead ': columnsTail)

151+ ) => KnownColumns ((column ::: ty) ': columnsHead ': columnsTail) where

152+ renderColumns _ =

153+ fromString (symbolVal' (proxy# :: Proxy# column))

154+ <> " "

155+ <> renderPGType (proxy# :: Proxy# ty)

156+ <> ", "

157+ <> renderColumns (proxy# :: Proxy# (columnsHead ': columnsTail))

squeel-postgresql/src/Squeel/PostgreSQL/Query.hs → squeel-postgresql/src/Squeel/PostgreSQL/Statement.hsrenamed+34−9

@@ -11,7 +11,7 @@

11 , UndecidableInstances

12#-}

14−module Squeel.PostgreSQL.Query where

14+module Squeel.PostgreSQL.Statement where

16import Data.Boolean

17import Data.ByteString (ByteString)

@@ -302,24 +302,24 @@ list `from` tabs = UnsafeSelection $

302 . recordToList

303 . rmap (Const . renderAliased renderExpression)

304

305−newtype Query

305+newtype Statement

306 (params :: [PGType])

307 (schema0 :: [(Symbol,[(Symbol,PGType)])])

308 (schema1 :: [(Symbol,[(Symbol,PGType)])])

309 (columns :: [(Symbol,PGType)])

310− = UnsafeQuery { renderQuery :: ByteString }

310+ = UnsafeStatement { renderStatement :: ByteString }

311

312−newtype PreparedQuery

312+newtype PreparedStatement

313 (params :: [PGType])

314 (schema0 :: [(Symbol,[(Symbol,PGType)])])

315 (schema1 :: [(Symbol,[(Symbol,PGType)])])

316 (columns :: [(Symbol,PGType)])

317− = UnsafePreparedQuery { renderPreparedQuery :: ByteString }

317+ = UnsafePreparedStatement { renderPreparedStatement :: ByteString }

318

319select

320 :: Selection params schema columns

321− -> Query params schema schema columns

321+ -> Statement params schema schema columns

322−select = UnsafeQuery . ("SELECT " <>) . (<> ";") . renderSelection

322+select = UnsafeStatement . ("SELECT " <>) . (<> ";") . renderSelection

323

324subselect

325 :: Aliased (Selection params schema) table

@@ -334,8 +334,8 @@ insertInto

334 :: HasTable table schema columns

335 => Alias table

336 -> Rec (Aliased (Expression params '[])) columns

337− -> Query params schema schema '[]

337+ -> Statement params schema schema '[]

338−insertInto (Alias table) expressions = UnsafeQuery $ "INSERT INTO "

338+insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "

339 <> fromString (symbolVal' table)

340 <> " (" <> ByteString.intercalate ", " aliases

341 <> ") VALUES ("

@@ -348,3 +348,28 @@ insertInto (Alias table) expressions = UnsafeQuery $ "INSERT INTO "

348 values = recordToList $ rmap

349 (\ (expression `As` _) -> Const (renderExpression expression))

350 expressions

351+

352+createTable

353+ :: (KnownSymbol table, KnownColumns columns)

354+ => Alias table

355+ -> Proxy# columns

356+ -> Statement '[] schema ((table ::: columns) ': schema) '[]

357+createTable (Alias table) columns = UnsafeStatement $ mconcat

358+ [ "CREATE TABLE "

359+ , fromString $ symbolVal' table

360+ , " ("

361+ , renderColumns columns

362+ , ");"

363+ ]

364+

365+class KnownSymbol table => DropTable table schema0 schema1

366+ | table schema0 -> schema1 where

367+ dropTable :: Alias table -> Statement '[] schema0 schema1 '[]

368+ dropTable (Alias table) = UnsafeStatement $

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

370+instance {-# OVERLAPPING #-}

371+ (KnownSymbol table, table ~ table')

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

373+instance {-# OVERLAPPABLE #-}

374+ (KnownSymbol table, DropTable table schema0 schema1)

375+ => DropTable table (tabCols ': schema0) (tabCols ': schema1)

squeel-postgresql/test/Squeel/PostgreSQL/QuerySpec.hs → squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hsrenamed+29−16

@@ -1,28 +1,29 @@

1{-# LANGUAGE

2 DataKinds

3+ , MagicHash

3 , OverloadedLabels

4 , OverloadedLabels

4 , OverloadedStrings

5 , OverloadedStrings

5− , PolyKinds

6 , TypeOperators

7#-}

9−module Squeel.PostgreSQL.QuerySpec where

9+module Squeel.PostgreSQL.StatementSpec where

11import Data.Boolean

12import Data.Function

13import Data.Vinyl

14+import GHC.Exts

14import Test.Hspec

15import Test.Hspec

16−import Squeel.PostgreSQL.Query

17+import Squeel.PostgreSQL.Statement

17import Squeel.PostgreSQL.Schema

18import Squeel.PostgreSQL.Schema

19spec :: Spec

20spec :: Spec

20spec = do

21spec = do

21 let

22 let

22− query `shouldRenderAs` str = renderQuery query `shouldBe` str

23+ query `shouldRenderAs` str = renderStatement query `shouldBe` str

23 it "correctly renders a simple SELECT query" $ do

24 it "correctly renders a simple SELECT query" $ do

24 let

25 let

25− statement :: Query '[] Tables Tables SumAndCol1

26+ statement :: Statement '[] Tables Tables SumAndCol1

26 statement = select $

27 statement = select $

27 ((#col1 + #col2) `As` #sum :& #col1 :& RNil)

28 ((#col1 + #col2) `As` #sum :& #col1 :& RNil)

28 `from` (#table1 & where_ true)

29 `from` (#table1 & where_ true)

@@ -30,7 +31,7 @@ spec = do

30 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 WHERE TRUE;"

31 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 WHERE TRUE;"

31 it "combines WHEREs using AND" $ do

32 it "combines WHEREs using AND" $ do

32 let

33 let

33− statement :: Query '[] Tables Tables SumAndCol1

34+ statement :: Statement '[] Tables Tables SumAndCol1

34 statement = select $

35 statement = select $

35 ((#col1 + #col2) `As` #sum :& #col1 :& RNil)

36 ((#col1 + #col2) `As` #sum :& #col1 :& RNil)

36 `from` (#table1 & where_ true & where_ false)

37 `from` (#table1 & where_ true & where_ false)

@@ -39,45 +40,45 @@ spec = do

39 it "performs sub SELECTs" $ do

40 it "performs sub SELECTs" $ do

40 let

41 let

41 selection = ((#col1 + #col2) `As` #sum :& #col1 :& RNil) `from` #table1

42 selection = ((#col1 + #col2) `As` #sum :& #col1 :& RNil) `from` #table1

42− statement :: Query '[] Tables Tables SumAndCol1

43+ statement :: Statement '[] Tables Tables SumAndCol1

43 statement = select $ starFrom (subselect (selection `As` #sub))

44 statement = select $ starFrom (subselect (selection `As` #sub))

44 statement `shouldRenderAs`

45 statement `shouldRenderAs`

45 "SELECT * FROM SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS sub;"

46 "SELECT * FROM SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS sub;"

46 it "does LIMIT clauses" $ do

47 it "does LIMIT clauses" $ do

47 let

48 let

48− statement :: Query '[] Tables Tables Columns

49+ statement :: Statement '[] Tables Tables Columns

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

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

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

51 statement `shouldRenderAs` "SELECT * FROM table1 LIMIT 1;"

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

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

52 let

53 let

53− statement :: Query '[] Tables Tables Columns

54+ statement :: Statement '[] Tables Tables Columns

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

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

55 statement `shouldRenderAs`

56 statement `shouldRenderAs`

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

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

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

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

58 let

59 let

59− statement :: Query '[ 'PGInt8] Tables Tables Columns

60+ statement :: Statement '[ 'PGInt8] Tables Tables Columns

60 statement = select $ starFrom (#table1 & limit param1)

61 statement = select $ starFrom (#table1 & limit param1)

61 statement `shouldRenderAs` "SELECT * FROM table1 LIMIT $1;"

62 statement `shouldRenderAs` "SELECT * FROM table1 LIMIT $1;"

62 it "does OFFSET clauses" $ do

63 it "does OFFSET clauses" $ do

63 let

64 let

64− statement :: Query '[] Tables Tables Columns

65+ statement :: Statement '[] Tables Tables Columns

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

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

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

67 statement `shouldRenderAs` "SELECT * FROM table1 OFFSET 1;"

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

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

68 let

69 let

69− statement :: Query '[] Tables Tables Columns

70+ statement :: Statement '[] Tables Tables Columns

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

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

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

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

72 it "correctly render simple INSERTs" $ do

73 it "correctly render simple INSERTs" $ do

73 let

74 let

74− statement :: Query '[] Tables Tables '[]

75+ statement :: Statement '[] Tables Tables '[]

75 statement = insertInto #table1 $ 2 `As` #col1 :& 4 `As` #col2 :& RNil

76 statement = insertInto #table1 $ 2 `As` #col1 :& 4 `As` #col2 :& RNil

76 statement `shouldRenderAs`

77 statement `shouldRenderAs`

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

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

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

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

79 let

80 let

80− statement :: Query '[] StudentsTable StudentsTable '[]

81+ statement :: Statement '[] StudentsTable StudentsTable '[]

81 statement = insertInto #students $

82 statement = insertInto #students $

82 "Robert'); DROP TABLE students;" `As` #name :& RNil

83 "Robert'); DROP TABLE students;" `As` #name :& RNil

83 statement `shouldRenderAs`

84 statement `shouldRenderAs`

@@ -90,7 +91,7 @@ spec = do

90 :& #shippers .&. #shipperVal `As` #shipperVal :& RNil

91 :& #shippers .&. #shipperVal `As` #shipperVal :& RNil

91 it "should render CROSS JOINs" $ do

92 it "should render CROSS JOINs" $ do

92 let

93 let

93− statement :: Query '[] JoinTables JoinTables ValueColumns

94+ statement :: Statement '[] JoinTables JoinTables ValueColumns

94 statement = select $ vals `from`

95 statement = select $ vals `from`

95 (tables (#orders & crossJoin #customers & crossJoin #shippers))

96 (tables (#orders & crossJoin #customers & crossJoin #shippers))

96 statement `shouldRenderAs`

97 statement `shouldRenderAs`

@@ -110,7 +111,7 @@ spec = do

110 (#orders .&. #customerID ==* #customers .&. #customerID)

111 (#orders .&. #customerID ==* #customers .&. #customerID)

111 & innerJoin #shippers

112 & innerJoin #shippers

112 (#orders .&. #shipperID ==* #shippers .&. #shipperID)

113 (#orders .&. #shipperID ==* #shippers .&. #shipperID)

113− selection :: Query '[] JoinTables JoinTables ValueColumns

114+ selection :: Statement '[] JoinTables JoinTables ValueColumns

114 selection = select $ vals `from` innerJoins

115 selection = select $ vals `from` innerJoins

115 selection `shouldRenderAs`

116 selection `shouldRenderAs`

116 "SELECT\

117 "SELECT\

@@ -122,6 +123,18 @@ spec = do

122 \ ON (orders.customerID = customers.customerID)\

123 \ ON (orders.customerID = customers.customerID)\

123 \ INNER JOIN shippers\

124 \ INNER JOIN shippers\

124 \ ON (orders.shipperID = shippers.shipperID);"

125 \ ON (orders.shipperID = shippers.shipperID);"

126+ it "should render simple CREATE TABLE statements" $ do

127+ let

128+ statement :: Statement '[] '[] Tables '[]

129+ statement = createTable #table1 (proxy# :: Proxy# Columns)

130+ statement `shouldRenderAs`

131+ "CREATE TABLE table1 (col1 int4, col2 int4);"

132+ it "should render DROP TABLE statements" $ do

133+ let

134+ statement :: Statement '[] Tables '[] '[]

135+ statement = dropTable #table1

136+ statement `shouldRenderAs`

137+ "DROP TABLE table1;"

125

138

126type Columns = '[ "col1" ::: 'PGInt4, "col2" ::: 'PGInt4]

139type Columns = '[ "col1" ::: 'PGInt4, "col2" ::: 'PGInt4]

127type Tables = '[ "table1" ::: Columns ]

140type Tables = '[ "table1" ::: Columns ]