8000 Test compiles · postgres-haskell/postgres-wire@a678443 · GitHub
[go: up one dir, main page]
Skip to content

Commit a678443

Browse files
VyacheslavHashovVyacheslavHashov
committed
Test compiles
1 parent 9fd5d0c commit a678443

File tree

5 files changed

+44
-38
lines changed

5 files changed

+44
-38
lines changed

‎src/Database/PostgreSQL/Driver/Error.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,9 @@ import Database.PostgreSQL.Protocol.Types (ErrorDesc)
99
-- All possible exceptions:
1010
-- SocketException
1111
-- DecodeException.
12+
-- IncorrectUsage.
13+
14+
data IncorrectUsage = IncorrectUsage
1215

1316
-- All possible errors.
1417
data Error

‎src/Database/PostgreSQL/Driver/Query.hs

Lines changed: 27 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -37,14 +37,35 @@ sendBatchAndSync = sendBatchEndBy Sync
3737
sendSimpleQuery :: ConnectionCommon -> B.ByteString -> IO (Either Error ())
3838
sendSimpleQuery conn q = do
3939
sendMessage (connRawConnection conn) $ SimpleQuery (StatementSQL q)
40-
pure $ pure ()
41-
-- TODO
42-
-- waitReadyForQuery conn
40+
checkErrors <$> collectUntilReadyForQuery conn
41+
where
42+
checkErrors = either
43+
(Left . ReceiverError)
44+
(maybe (Right ()) (Left . PostgresError) . findFirstError)
45+
46+
waitReadyForQuery :: Connection -> IO (Either Error ())
47+
waitReadyForQuery conn =
48+
readChan (connOutChan conn) >>=
49+
either (pure . Left . ReceiverError) handleDataMessage
50+
where
51+
handleDataMessage msg = case msg of
52+
(DataError e) -> do
53+
-- We should wait for ReadForQuery anyway.
54+
waitReadyForQuery conn
55+
pure . Left $ PostgresError e
56+
(DataMessage _) -> error "throw incorrect usage here"
57+
DataReady -> pure $ Right ()
4358

4459
-- | Public
45-
-- TODO
46-
-- readNextData :: Connection -> IO (Either Error DataRows)
47-
-- readNextData conn = readChan $ connOutChan conn
60+
readNextData :: Connection -> IO (Either Error DataRows)
61+
readNextData conn =
62+
readChan (connOutChan conn) >>=
63+
either (pure . Left . ReceiverError) handleDataMessage
64+
where
65+
handleDataMessage msg = case msg of
66+
(DataError e) -> pure . Left $ PostgresError e
67+
(DataMessage rows) -> pure . Right $ rows
68+
DataReady -> error "throw Incorrect usage here"
4869

4970
-- Helper
5071
sendBatchEndBy :: ClientMessage -> Connection -> [Query] -> IO ()

‎src/Database/PostgreSQL/Protocol/Types.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ data ServerVersion = ServerVersion !Word8 !Word8 !Word8 !ByteString
4848
-- It is guaranted that a single strict chunk of the `ByteString`
4949
-- contains integer number of `DataRow`s.
5050
newtype DataRows = DataRows BL.ByteString
51-
deriving (Show)
51+
deriving (Show, Eq)
5252

5353
-- | Ad-hoc type only for data rows.
5454
data DataMessage

‎tests/Driver.hs

Lines changed: 11 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ import Control.Monad
66
import Data.Maybe
77
import Data.Either
88
import qualified Data.ByteString as B
9+
import qualified Data.ByteString.Lazy as BL
910
import qualified Data.ByteString.Char8 as BS
1011
import qualified Data.Vector as V
1112

@@ -31,7 +32,6 @@ testDriver = testGroup "Driver"
3132
, testCase "Describe statement with no data" testDescribeStatementNoData
3233
, testCase "Describe empty statement" testDescribeStatementEmpty
3334
, testCase "SimpleQuery" testSimpleQuery
34-
, testCase "SimpleAndExtendedQuery" testSimpleAndExtendedQuery
3535
, testCase "PreparedStatementCache" testPreparedStatementCache
3636
, testCase "Query with large response" testLargeQuery
3737
]
@@ -48,8 +48,9 @@ fromRight :: Either e a -> a
4848
fromRight (Right v) = v
4949
fromRight _ = error "fromRight"
5050

51-
fromMessage :: Either e DataMessage -> B.ByteString
52-
fromMessage (Right (DataMessage [v])) = fromJust $ V.head v
51+
fromMessage :: Either e DataRows -> B.ByteString
52+
-- TODO
53+
fromMessage (Right (DataRows bs)) = B.drop 9 $ BL.toStrict bs
5354
fromMessage _ = error "from message"
5455

5556
-- | Single batch.
@@ -111,16 +112,16 @@ assertQueryNoData q = withConnection $ \c -> do
111112
sendBatchAndSync c [q]
112113
r <- fromRight <$> readNextData c
113114
waitReadyForQuery c
114-
DataMessage [] @=? r
115+
DataRows "" @=? r
115116

116-
-- | Asserts that all the received data rows are in form (Right _)
117+
-- | Asserts that all the received data messages are in form (Right _)
117118
checkRightResult :: Connection -> Int -> Assertion
118119
checkRightResult conn 0 = pure ()
119120
checkRightResult conn n = readNextData conn >>=
120121
either (const $ assertFailure "Result is invalid")
121122
(const $ checkRightResult conn (n - 1))
122123

123-
-- | Asserts that (Left _) as result exists in the received data rows.
124+
-- | Asserts that (Left _) as result exists in the received data messages.
124125
checkInvalidResult :: Connection -> Int -> Assertion
125126
checkInvalidResult conn 0 = assertFailure "Result is right"
126127
checkInvalidResult conn n = readNextData conn >>=
@@ -149,7 +150,7 @@ testInvalidBatch = do
149150

150151
-- | Describes usual statement.
151152
testDescribeStatement :: IO ()
152-
testDescribeStatement = withConnection $ \c -> do
153+
testDescribeStatement = withConnectionCommon $ \c -> do
153154
r <- describeStatement c $
154155
"select typname, typnamespace, typowner, typlen, typbyval,"
155156
<> "typcategory, typispreferred, typisdefined, typdelim, typrelid,"
@@ -159,21 +160,21 @@ testDescribeStatement = withConnection $ \c -> do
159160

160161
-- | Describes statement that returns no data.
161162
testDescribeStatementNoData :: IO ()
162-
testDescribeStatementNoData = withConnection $ \c -> do
163+
testDescribeStatementNoData = withConnectionCommon $ \c -> do
163164
r <- fromRight <$> describeStatement c "SET client_encoding TO UTF8"
164165
assertBool "Should be empty" $ V.null (fst r)
165166
assertBool "Should be empty" $ V.null (snd r)
166167

167168
-- | Describes statement that is empty string.
168169
testDescribeStatementEmpty :: IO ()
169-
testDescribeStatementEmpty = withConnection $ \c -> do
170+
testDescribeStatementEmpty = withConnectionCommon $ \c -> do
170171
r <- fromRight <$> describeStatement c ""
171172
assertBool "Should be empty" $ V.null (fst r)
172173
assertBool "Should be empty" $ V.null (snd r)
173174

174175
-- | Query using simple query protocol.
175176
testSimpleQuery :: IO ()
176-
testSimpleQuery = withConnection $ \c -> do
177+
testSimpleQuery = withConnectionCommon $ \c -> do
177178
r <- sendSimpleQuery c $
178179
"DROP TABLE IF EXISTS a;"
179180
<> "CREATE TABLE a(v int);"
@@ -182,25 +183,6 @@ testSimpleQuery = withConnection $ \c -> do
182183
<> "DROP TABLE a;"
183184
assertBool "Should be Right" $ isRight r
184185

185-
-- | Simple and extended queries in a sinle connection.
186-
testSimpleAndExtendedQuery :: IO ()
187-
testSimpleAndExtendedQuery = withConnection $ \c -> do
188-
let a = "7"
189-
b = "2"
190-
d = "5"
191-
sendBatchAndSync c [ makeQuery1 a , makeQuery1 b]
192-
waitReadyForQuery c
193-
checkRightResult c 2
194-
195-
rs <- sendSimpleQuery c "SELECT * FROM generate_series(1, 10)"
196-
assertBool "Should be Right" $ isRight rs
197-
198-
sendBatchAndSync c [makeQuery1 d]
199-
fr <- waitReadyForQuery c
200-
assertBool "Should be Right" $ isRight fr
201-
r <- fromMessage <$> readNextData c
202-
r @=? d
203-
204186
-- | Test that cache of statements works.
205187
testPreparedStatementCache :: IO ()
206188
testPreparedStatementCache = withConnection $ \c -> do

‎tests/test.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,14 @@
11
import Test.Tasty (defaultMain, testGroup)
22

33
import Protocol
4-
-- import Driver
4+
import Driver
55
-- import Fault
66
import Misc
77

88
main :: IO ()
99
main = defaultMain $ testGroup "Postgres-wire"
1010
[ testProtocolMessages
11-
-- , testDriver
11+
, testDriver
1212
-- , testFaults
1313
, testMisc
1414
]

0 commit comments

Comments
 (0)
0