efdb2eb · squeal · git.iko.soy

git.iko.soy/squeal

replace vinyl with generics-sop

Step 0 for using generics-sop to govern Squeel.Binary

commitefdb2ebe91596ff9edd74b2bf5a47cc3ff303df1 authorEitan Chatav <eitan.chatav@gmail.com> dateThu 29 Jun 2017, 19:16 (9 years ago) parent40400fa

6 files changed+61−63

compare with dev

unifiedsplit

squeel-postgresql/exe/Example.hs+7−7 squeel-postgresql/squeel-postgresql.cabal+3−3 squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+7−8 squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+3−4 squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+28−28 squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+13−13

squeel-postgresql/exe/Example.hs+7−7

@@ -13,7 +13,7 @@ import Control.Monad.Base

1313import Data.Function ((&))

1414import Data.Int

1515import Data.Monoid

16−import Data.Vinyl

16+import Generics.SOP

1717import Squeel.PostgreSQL

1818

1919import qualified Data.ByteString.Char8 as Char8

@@ -29,18 +29,18 @@ main = do

2929 connection1 <- flip execPQ connection0 $ pqExec $

3030 createTable #students

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

32− :& RNil )

32+ :* Nil )

3333 >>>

3434 createTable #table1

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

36− :& (int4 & notNull) `As` #col2

37− :& RNil )

36+ :* (int4 & notNull) `As` #col2

37+ :* Nil )

3838 connection2 <- flip execPQ connection1 $ do

3939 _insertTable1Result <- pqExec $

40− insertInto #table1 ( 1 `As` #col1 :& 2 `As` #col2 :& RNil )

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

4141 >>>

42− insertInto #table1 ( 3 `As` #col1 :& 4 `As` #col2 :& RNil )

43− Just selectTable1Result <- flip pqExecParams RNil $

42+ insertInto #table1 ( 3 `As` #col1 :* 4 `As` #col2 :* Nil )

43+ Just selectTable1Result <- flip pqExecParams Nil $

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

4545 Just (Right value00) <- getvalue selectTable1Result (RowNumber 0) colNum0

4646 Just (Right value01) <- getvalue selectTable1Result (RowNumber 0) colNum1

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

@@ -25,6 +25,7 @@ library

2525 , base

2626 , Boolean

2727 , bytestring

28+ , generics-sop

2829 , lifted-base

2930 , monad-control

3031 , mtl

@@ -35,7 +36,6 @@ library

3536 , time

3637 , transformers-base

3738 , uuid

38− , vinyl

3939

4040test-suite squeel-postgresql-test

4141 default-language: Haskell2010

@@ -49,9 +49,9 @@ test-suite squeel-postgresql-test

4949 build-depends:

5050 base

5151 , Boolean

52+ , generics-sop

5253 , hspec

5354 , squeel-postgresql

54− , vinyl

5555

5656executable squeel-postgresql-example

5757 default-language: Haskell2010

@@ -61,9 +61,9 @@ executable squeel-postgresql-example

6161 build-depends:

6262 base

6363 , bytestring

64+ , generics-sop

6465 , squeel-postgresql

6566 , transformers-base

66− , vinyl

6767

6868source-repository head

6969 type: git

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

@@ -15,8 +15,7 @@ import Control.Arrow (left)

1515import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode)

1616import Data.ByteString (ByteString)

1717import Data.Int (Int16,Int32,Int64)

18−import Data.Vinyl

19−import Data.Vinyl.Functor

18+import Generics.SOP

2019import PostgreSQL.Binary.Decoding (Value)

2120import PostgreSQL.Binary.Encoding (Encoding)

2221import Data.Scientific (Scientific)

@@ -84,13 +83,13 @@ instance FromValue pg ty => FromValue (column ::: 'Required ('NotNull pg)) ty wh

8483 fromValue _ = fromValue (proxy# :: Proxy# pg)

8584

8685class FromValues pgs xs where

87− decodeValues :: Proxy# pgs -> Rec (Const ByteString) xs -> Rec (Either Text) xs

88−instance FromValues '[] '[] where decodeValues _ _ = RNil

86+ decodeValues :: Proxy# pgs -> NP (K ByteString) xs -> NP (Either Text) xs

87+instance FromValues '[] '[] where decodeValues _ _ = Nil

8988instance (FromValue pg x, FromValues pgs xs)

9089 => FromValues (pg ': pgs) (x ': xs) where

91− decodeValues _ (Const result :& results) =

90+ decodeValues _ (K result :* results) =

9291 decodeValue (proxy# :: Proxy# pg) result

93− :& decodeValues (proxy# :: Proxy# pgs) results

92+ :* decodeValues (proxy# :: Proxy# pgs) results

9493

9594class ToValue x pg where

9695 toValue :: Proxy# pg -> x -> Encoding

@@ -138,10 +137,10 @@ instance ToValue DiffTime 'PGInterval where

138137 toValue _ = Encoder.interval_int

139138

140139class ToValues xs pgs where

141− toValues :: Proxy# pgs -> Rec Identity xs -> [ByteString]

140+ toValues :: Proxy# pgs -> NP I xs -> [ByteString]

142141instance ToValues '[] '[] where toValues _ _ = []

143142instance (ToValue x pg, ToValues xs pgs)

144143 => ToValues (x ': xs) (pg ': pgs) where

145− toValues _ (Identity x :& xs)

144+ toValues _ (I x :* xs)

146145 = Encoder.encodingBytes ((toValue (proxy# :: Proxy# pg)) x)

147146 : toValues (proxy# :: Proxy# pgs) xs

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

@@ -23,8 +23,7 @@ import Control.Monad.Trans

2323import Control.Monad.Trans.Control

2424import Data.ByteString (ByteString)

2525import Data.Text (Text)

26−import Data.Vinyl

27−import Data.Vinyl.Functor

26+import Generics.SOP

2827import GHC.Exts

2928import GHC.TypeLits

3029

@@ -72,7 +71,7 @@ class MonadPQ pq where

7271 pqExecParams

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

7473 => Statement ps ys db0 db1

75− -> Rec Identity xs

74+ -> NP I xs

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

7776

7877 pqPrepare

@@ -84,7 +83,7 @@ class MonadPQ pq where

8483 pqExecPrepared

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

8685 => PreparedStatement ps ys db0 db1

87− -> Rec Identity xs

86+ -> NP I xs

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

8988

9089instance MonadPQ PQ where

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

@@ -20,8 +20,7 @@ import Data.ByteString (ByteString)

2020import Data.Maybe

2121import Data.Monoid

2222import Data.String

23−import Data.Vinyl

24−import Data.Vinyl.Functor

23+import Generics.SOP

2524import GHC.Exts

2625import GHC.OverloadedLabels

2726import GHC.TypeLits

@@ -117,8 +116,8 @@ unsafeFunction

117116 :: ByteString

118117 -> Expression params tables xty

119118 -> Expression params tables yty

120−unsafeFunction fn x = UnsafeExpression $ mconcat

121− [fn, "(", renderExpression x, ")"]

119+unsafeFunction fun x = UnsafeExpression $ mconcat

120+ [fun, "(", renderExpression x, ")"]

122121

123122instance PGNum ty => Num (Expression params tables ('Required (nullity ty))) where

124123 (+) = unsafeBinaryOp "+"

@@ -407,7 +406,8 @@ Alias tab `dotStarFrom` tabs = UnsafeSelection $

407406 fromString (symbolVal' tab) <> ".* FROM " <> renderFrom tabs

408407

409408from

410− :: Rec (Aliased (Expression params tables)) columns

409+ :: SListI columns

410+ => NP (Aliased (Expression params tables)) columns

411411 -> From params schema tables

412412 -> Selection params schema columns

413413list `from` tabs = UnsafeSelection $

@@ -415,8 +415,8 @@ list `from` tabs = UnsafeSelection $

415415 where

416416 renderList

417417 = ByteString.intercalate ", "

418− . recordToList

419− . rmap (Const . renderAliased renderExpression)

418+ . hcollapse

419+ . hmap (K . renderAliased renderExpression)

420420

421421select

422422 :: Selection params schema columns

@@ -436,9 +436,9 @@ INSERT statements

436436-----------------------------------------}

437437

438438insertInto

439− :: HasTable table schema columns

439+ :: (SListI columns, HasTable table schema columns)

440440 => Alias table

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

441+ -> NP (Aliased (Expression params '[])) columns

442442 -> Statement params '[] schema schema

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

444444 <> fromString (symbolVal' table)

@@ -447,11 +447,11 @@ insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "

447447 <> ByteString.intercalate ", " values

448448 <> ");"

449449 where

450− aliases = recordToList $ rmap

451− (\ (_ `As` Alias name) -> Const (fromString (symbolVal' name)))

450+ aliases = hcollapse $ hmap

451+ (\ (_ `As` Alias name) -> K (fromString (symbolVal' name)))

452452 expressions

453− values = recordToList $ rmap

454− (\ (expression `As` _) -> Const (renderExpression expression))

453+ values = hcollapse $ hmap

454+ (\ (expression `As` _) -> K (renderExpression expression))

455455 expressions

456456

457457{-----------------------------------------

@@ -486,16 +486,16 @@ serial :: TypeExpression ('Optional ('NotNull 'PGInt4))

486486serial = UnsafeTypeExpression "serial"

487487

488488createTable

489− :: KnownSymbol table

489+ :: (KnownSymbol table, SListI columns)

490490 => Alias table

491− -> Rec (Aliased TypeExpression) columns

491+ -> NP (Aliased TypeExpression) columns

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

493493createTable (Alias table) columns = UnsafeStatement $ mconcat

494494 [ "CREATE TABLE "

495495 , fromString $ symbolVal' table

496496 , " ("

497− , ByteString.intercalate ", " . recordToList $

498− rmap (Const . renderColumn) columns

497+ , ByteString.intercalate ", " . hcollapse $

498+ hmap (K . renderColumn) columns

499499 , ");"

500500 ]

501501 where

@@ -523,33 +523,33 @@ instance {-# OVERLAPPABLE #-}

523523UPDATE statements

524524-----------------------------------------}

525525

526−set :: g x -> (Maybe `Compose` g) x

527−set = Compose . Just

526+set :: g x -> (Maybe :.: g) x

527+set = Comp . Just

528528

529−same :: (Maybe `Compose` g) x

530−same = Compose Nothing

529+same :: (Maybe :.: g) x

530+same = Comp Nothing

531531

532532update

533− :: HasTable table schema columns

533+ :: (HasTable table schema columns, SListI columns)

534534 => Alias table

535− -> Rec (Aliased (Maybe `Compose` Expression params '[table ::: columns])) columns

535+ -> NP (Aliased (Maybe :.: Expression params '[table ::: columns])) columns

536536 -> Expression params '[table ::: columns] ('Required ('NotNull 'PGBool))

537537 -> Statement params '[] schema schema

538538update (Alias table) columns where' = UnsafeStatement $ mconcat

539539 [ "UPDATE "

540540 , fromString $ symbolVal' table

541541 , " SET "

542− , ByteString.intercalate ", " . catMaybes . recordToList $

543− rmap (Const . renderSet) columns

542+ , ByteString.intercalate ", " . catMaybes . hcollapse $

543+ hmap (K . renderSet) columns

544544 , " WHERE ", renderExpression where'

545545 ] where

546546 renderSet

547− :: Aliased (Maybe `Compose` Expression params tables) column

547+ :: Aliased (Maybe :.: Expression params tables) column

548548 -> Maybe ByteString

549549 renderSet = \case

550− Compose (Just expression) `As` Alias column -> Just $ mconcat

550+ Comp (Just expression) `As` Alias column -> Just $ mconcat

551551 [ fromString $ symbolVal' column

552552 , " = "

553553 , renderExpression expression

554554 ]

555− Compose Nothing `As` _ -> Nothing

555+ Comp Nothing `As` _ -> Nothing

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

@@ -10,7 +10,7 @@ module Squeel.PostgreSQL.StatementSpec where

1010

1111import Data.Boolean

1212import Data.Function

13−import Data.Vinyl

13+import Generics.SOP hiding (from)

1414import Test.Hspec

1515

1616import Squeel.PostgreSQL.Statement

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

2424 let

2525 statement :: Statement '[] SumAndCol1 Tables Tables

2626 statement = select $

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

27+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)

2828 `from` (#table1 & where_ true)

2929 statement `shouldRenderAs`

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

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

3232 let

3333 statement :: Statement '[] SumAndCol1 Tables Tables

3434 statement = select $

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

35+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)

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

3737 statement `shouldRenderAs`

3838 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE (TRUE AND FALSE);"

3939 it "performs sub SELECTs" $ do

4040 let

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

41+ selection = ((#col1 + #col2) `As` #sum :* #col1 :* Nil) `from` #table1

4242 statement :: Statement '[] SumAndCol1 Tables Tables

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

4444 statement `shouldRenderAs`

@@ -72,22 +72,22 @@ spec = do

7272 it "correctly render simple INSERTs" $ do

7373 let

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

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

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

7676 statement `shouldRenderAs`

7777 "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

8181 statement = insertInto #students $

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

82+ "Robert'); DROP TABLE students;" `As` #name :* Nil

8383 statement `shouldRenderAs`

8484 "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"

8585 describe "JOINs" $ do

8686 let

8787 vals =

8888 #orders &. #orderVal `As` #orderVal

89− :& #customers &. #customerVal `As` #customerVal

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

89+ :* #customers &. #customerVal `As` #customerVal

90+ :* #shippers &. #shipperVal `As` #shipperVal :* Nil

9191 it "should render CROSS JOINs" $ do

9292 let

9393 statement :: Statement '[] ValueColumns JoinTables JoinTables

@@ -135,15 +135,15 @@ spec = do

135135 it "should render CREATE TABLE statements" $ do

136136 createTable #table1

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

138− :& (int4 & notNull) `As` #col2

139− :& RNil)

138+ :* (int4 & notNull) `As` #col2

139+ :* Nil)

140140 `shouldRenderAs`

141141 "CREATE TABLE table1 (col1 int4 NOT NULL, col2 int4 NOT NULL);"

142142 createTable #table2

143143 ( serial `As` #col1

144− :& text `As` #col2

145− :& (int8 & notNull & default_ 8) `As` #col3

146− :& RNil)

144+ :* text `As` #col2

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

146+ :* Nil)

147147 `shouldRenderAs`

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

149149 it "should render DROP TABLE statements" $ do