8000 Test passing · postgres-haskell/postgres-wire@6f87e60 · GitHub
[go: up one dir, main page]

Skip to c 8000 ontent

Commit 6f87e60

Browse files
Test passing
1 parent a678443 commit 6f87e60

File tree

9 files changed

+52
-54
lines changed

9 files changed

+52
-54
lines changed

postgres-wire.cabal

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -72,8 +72,8 @@ test-suite postgres-wire-test
7272
hs-source-dirs: tests
7373
main-is: test.hs
7474
other-modules: Connection
75-
-- , Driver
76-
-- , Fault
75+
, Driver
76+
, Fault
7777
, Protocol
7878
, Misc
7979
build-depends: base

src/Database/PostgreSQL/Driver/Connection.hs

Lines changed: 29 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ module Database.PostgreSQL.Driver.Connection where
22

33
import qualified Data.ByteString as B
44
import qualified Data.ByteString.Char8 as BS(pack, unpack)
5+
import qualified Data.ByteString.Lazy as BL
56
import Data.ByteString.Lazy (toStrict)
67
import Data.ByteString.Builder (Builder, toLazyByteString)
78
import Control.Monad
@@ -69,8 +70,8 @@ defaultNotificationHandler = const $ pure ()
6970
type DataDispatcher
7071
= InDataChan
7172
-> ServerMessage
72-
-> [V.Vector (Maybe B.ByteString)]
73-
-> IO [V.Vector (Maybe B.ByteString)]
73+
-> [B.ByteString]
74+
-> IO [B.ByteString]
7475

7576
-- | Public
7677
connect :: ConnectionSettings -> IO (Either Error Connection)
@@ -233,7 +234,7 @@ receiverThread rawConn dataChan = receiveLoop Nothing "" []
233234
receiveLoop
234235
:: Maybe Header
235236
-> B.ByteString
236-
-> [V.Vector (Maybe B.ByteString)] -> IO ()
237+
-> [B.ByteString] -> IO ()
237238
-- Parsing header
238239
receiveLoop Nothing bs acc
239240
| B.length bs < 5 = do
@@ -302,25 +303,31 @@ receiverThreadCommon rawConn chan msgFilter ntfHandler =
302303
dispatchExtended :: DataDispatcher
303304
dispatchExtended dataChan message acc = case message of
304305
-- Command is completed, return the result
305-
-- CommandComplete _ -> do
306-
-- writeChan dataChan . Right $ reverse acc
307-
-- pure []
308-
-- -- note that data rows go in reversed order
309-
-- DataRow row -> pure (row:acc)
310-
-- -- PostgreSQL sends this if query string was empty and datarows should be
311-
-- -- empty, but anyway we return data collected in `acc`.
312-
-- EmptyQueryResponse -> do
313-
-- writeChan dataChan . Right $ reverse acc
314-
-- pure []
315-
-- -- On ErrorResponse we should discard all the collected datarows.
316-
-- ErrorResponse desc -> do
317-
-- writeChan dataChan $ Left $ PostgresError desc
318-
-- pure []
319-
-- -- We does not handled `PortalSuspended` because we always send `execute`
320-
-- -- with no limit.
321-
-- -- PortalSuspended -> pure acc
322-
323-
-- -- do nothing on other messages
306+
CommandComplete _ -> do
307+
writeChan dataChan . Right . DataMessage . DataRows . BL.fromChunks
308+
$ reverse acc
309+
pure []
310+
-- note that data rows go in reversed order
311+
DataRow row -> pure (row:acc)
312+
-- PostgreSQL sends this if query string was empty and datarows should be
313+
-- empty, but anyway we return data collected in `acc`.
314+
EmptyQueryResponse -> do
315+
writeChan dataChan . Right . DataMessage . DataRows . BL.fromChunks
316+
$ reverse acc
317+
pure []
318+
-- On ErrorResponse we should discard all the collected datarows.
319+
ErrorResponse desc -> do
320+
writeChan dataChan $ Right $ DataError desc
321+
pure []
322+
-- to know when command processing is finished
323+
ReadForQuery{} -> do
324+
writeChan dataChan $ Right DataReady
325+
pure acc
326+
-- We does not handled `PortalSuspended` because we always send `execute`
327+
-- with no limit.
328+
-- PortalSuspended -> pure acc
329+
330+
-- do nothing on other messages
324331
_ -> pure acc
325332

326333
-- | For testings purposes.

src/Database/PostgreSQL/Driver/Query.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,7 @@ waitReadyForQuery conn =
5353
-- We should wait for ReadForQuery anyway.
5454
waitReadyForQuery conn
5555
pure . Left $ PostgresError e
56-
(DataMessage _) -> error "throw incorrect usage here"
56+
(DataMessage _) -> error "incorrect usage waitReadyForQuery"
5757
DataReady -> pure $ Right ()
5858

5959
-- | Public
@@ -65,7 +65,7 @@ readNextData conn =
6565
handleDataMessage msg = case msg of
6666
(DataError e) -> pure . Left $ PostgresError e
6767
(DataMessage rows) -> pure . Right $ rows
68-
DataReady -> error "throw Incorrect usage here"
68+
DataReady -> error "incorrect usage readNextData"
6969

7070
-- Helper
7171
sendBatchEndBy :: ClientMessage -> Connection -> [Query] -> IO ()

src/Database/PostgreSQL/Protocol/Decoders.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -58,8 +58,8 @@ decodeServerMessage (Header c len) = case chr $ fromIntegral c of
5858
>>= eitherToDecode . parseCommandResult)
5959
-- Dont parse data rows here.
6060
'D' -> do
61-
getByteString len
62-
pure DataRow
61+
bs <- getByteString len
62+
pure $ DataRow ("abcde" <> bs)
6363
'I' -> pure EmptyQueryResponse
6464
'E' -> ErrorResponse <$>
6565
(getByteString len >>=

src/Database/PostgreSQL/Protocol/Types.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -161,7 +161,7 @@ data ServerMessage
161161
| CloseComplete
162162
| CommandComplete CommandResult
163163
-- DataRows lays in separate data type
164-
| DataRow
164+
| DataRow ByteString
165165
| EmptyQueryResponse
166166
| ErrorResponse !ErrorDesc
167167
| NoData

tests/Driver.hs

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,8 @@ fromRight _ = error "fromRight"
5050

5151
fromMessage :: Either e DataRows -> B.ByteString
5252
-- TODO
53-
fromMessage (Right (DataRows bs)) = B.drop 9 $ BL.toStrict bs
53+
-- 5 bytes -header, 2 bytes -count, 4 bytes - length
54+
fromMessage (Right (DataRows bs)) = B.drop 11 $ BL.toStrict bs
5455
fromMessage _ = error "from message"
5556

5657
-- | Single batch.
@@ -59,10 +60,10 @@ testBatch = withConnection $ \c -> do
5960
let a = "5"
6061
b = "3"
6162
sendBatchAndSync c [makeQuery1 a, makeQuery1 b]
62-
waitReadyForQuery c
6363

6464
r1 <- readNextData c
6565
r2 <- readNextData c
66+
waitReadyForQuery c
6667
a @=? fromMessage r1
6768
b @=? fromMessage r2
6869

@@ -145,7 +146,6 @@ testInvalidBatch = do
145146
where
146147
assertInvalidBatch desc qs = withConnection $ \c -> do
147148
sendBatchAndSync c qs
148-
waitReadyForQuery c
149149
checkInvalidResult c $ length qs
150150

151151
-- | Describes usual statement.
@@ -191,10 +191,10 @@ testPreparedStatementCache = withConnection $ \c -> do
191191
sendBatchAndSync c [ makeQuery1 (BS.pack (show a))
192192
, makeQuery1 (BS.pack (show b))
193193
, makeQuery2 (BS.pack (show a)) (BS.pack (show b))]
194-
waitReadyForQuery c
195194
r1 <- fromMessage <$> readNextData c
196195
r2 <- fromMessage <$> readNextData c
197196
r3 <- fromMessage <$> readNextData c
197+
waitReadyForQuery c
198198

199199
BS.pack (show a) @=? r1
200200
BS.pack (show b) @=? r2
@@ -208,8 +208,8 @@ testPreparedStatementCache = withConnection $ \c -> do
208208
testLargeQuery :: IO ()
209209
testLargeQuery = withConnection $ \c -> do
210210
sendBatchAndSync c [Query largeStmt V.empty Text Text NeverCache ]
211-
waitReadyForQuery c
212211
r <- readNextData c
212+
waitReadyForQuery c
213213
assertBool "Should be Right" $ isRight r
214214
where
215215
largeStmt = "select typname, typnamespace, typowner, typlen, typbyval,"

tests/Fault.hs

Lines changed: 8 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -31,9 +31,7 @@ longQuery = Query "SELECT pg_sleep(5)" V.empty Text Text NeverCache
3131

3232
testFaults :: TestTree
3333
testFaults = testGroup "Faults"
34-
[ makeInterruptTest "Single batch by waitReadyForQuery"
35-
testBatchReadyForQuery
36-
, makeInterruptTest "Single batch by readNextData "
34+
[ makeInterruptTest "Single batch by readNextData "
3735
testBatchNextData
3836
, makeInterruptTest "Simple Query"
3937
testSimpleQuery
@@ -48,44 +46,37 @@ testFaults = testGroup "Faults"
4846
, ("other exception", throwOtherException)
4947
]
5048

51-
testBatchReadyForQuery :: (Connection -> IO ()) -> IO ()
52-
testBatchReadyForQuery interruptAction = withConnection $ \c -> do
53-
sendBatchAndSync c [longQuery]
54-
interruptAction c
55-
r <- waitReadyForQuery c
56-
assertUnexpected r
57-
5849
testBatchNextData :: (Connection -> IO ()) -> IO ()
5950
testBatchNextData interruptAction = withConnection $ \c -> do
6051
sendBatchAndSync c [longQuery]
6152
interruptAction c
6253
r <- readNextData c
6354
assertUnexpected r
6455

65-
testSimpleQuery :: (Connection -> IO ()) -> IO ()
66-
testSimpleQuery interruptAction = withConnection $ \c -> do
56+
testSimpleQuery :: (ConnectionCommon -> IO ()) -> IO ()
57+
testSimpleQuery interruptAction = withConnectionCommon $ \c -> do
6758
asyncVar <- async $ sendSimpleQuery c "SELECT pg_sleep(5)"
6859
-- Make sure that query was sent.
69-
threadDelay 1000000
60+
threadDelay 500000
7061
interruptAction c
7162
r <- wait asyncVar
7263
assertUnexpected r
7364

74-
closeSocket :: Connection -> IO ()
65+
closeSocket :: AbsConnection c -> IO ()
7566
closeSocket = rClose . connRawConnection
7667

77-
throwSocketException :: Connection -> IO ()
68+
throwSocketException :: AbsConnection c -> IO ()
7869
throwSocketException conn = do
7970
let exc = SocketException 2
8071
maybe (pure ()) (`throwTo` exc) =<< deRefWeak (connReceiverThread conn)
8172

82-
throwOtherException :: Connection -> IO ()
73+
throwOtherException :: AbsConnection c -> IO ()
8374
throwOtherException conn = do
8475
let exc = PatternMatchFail "custom exc"
8576
maybe (pure ()) (`throwTo` exc) =<< deRefWeak (connReceiverThread conn)
8677

8778
assertUnexpected :: Show a => Either Error a -> Assertion
88-
assertUnexpected (Left (UnexpectedError _)) = pure ()
79+
assertUnexpected (Left _) = pure ()
8980
assertUnexpected (Right v) = assertFailure $
9081
"Expected Unexpected error, but got " ++ show v
9182

tests/Protocol.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,7 @@ testExtendedQuery = withConnectionCommonAll $ \c -> do
7676
isCloseComplete _ = False
7777
isParseComplete ParseComplete = True
7878
isParseComplete _ = False
79-
isDataRow DataRow = True
79+
isDataRow DataRow{} = True
8080
isDataRow _ = False
8181
isCommandComplete (CommandComplete _) = True
8282
isCommandComplete _ = False

tests/test.hs

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

33
import Protocol
44
import Driver
5-
-- import Fault
5+
import Fault
66
import Misc
77

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

0 commit comments

Comments
 (0)
0