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

Commit d7c4984

Browse files
VyacheslavHashovVyacheslavHashov
committed
Test sending queries
1 parent 41f90ee commit d7c4984

File tree

3 file 8000 s changed

+51
-5
lines changed

3 files changed

+51
-5
lines changed

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

Lines changed: 48 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,18 @@
1+
{-# language OverloadedLists #-}
2+
{-# language OverloadedStrings #-}
13
module Database.PostgreSQL.Protocol.Connection where
24

35

46
import qualified Data.ByteString as B
57
import Data.ByteString.Lazy (toStrict)
68
import Data.ByteString.Builder (Builder, toLazyByteString)
79
import Control.Monad
10+
import Data.Traversable
11+
import Data.Foldable
12+
import Control.Applicative
813
import Data.Monoid
914
import Control.Concurrent
15+
import Data.Binary.Get (Decoder(..), runGetIncremental, pushChunk)
1016
import Data.Maybe (fromJust)
1117
import System.Socket hiding (connect, close)
1218
import qualified System.Socket as Socket (connect, close)
@@ -17,6 +23,7 @@ import System.Socket.Family.Unix
1723

1824
import Database.PostgreSQL.Protocol.Settings
1925
import Database.PostgreSQL.Protocol.Encoders
26+
import Database.PostgreSQL.Protocol.Decoders
2027
import Database.PostgreSQL.Protocol.Types
2128

2229

@@ -31,10 +38,11 @@ connect :: ConnectionSettings -> IO Connection
3138
connect settings = do
3239
s <- socket
3340
Socket.connect s address
34-
tid <- forkIO $ forever $ do
35-
r <- receive s 4096 mempty
36-
print r
3741
sendMessage s $ encodeStartMessage $ consStartupMessage settings
42+
r <- receive s 4096 mempty
43+
readAuthMessage r
44+
45+
tid <- forkIO $ receiverThread s
3846
pure $ Connection s tid
3947

4048
close :: Connection -> IO ()
@@ -52,3 +60,40 @@ sendMessage sock msg = void $ do
5260
print smsg
5361
send sock smsg mempty
5462

63+
readAuthMessage :: B.ByteString -> IO ()
64+
readAuthMessage s =
65+
case pushChunk (runGetIncremental decodeAuthResponse) s of
66+
Done _ _ r -> case r of
67+
AuthenticationOk -> putStrLn "Auth ok"
68+
_ -> error "Invalid auth"
69+
f -> error $ show s
70+
71+
receiverThread :: UnixSocket -> IO ()
72+
receiverThread sock = forever $ do
73+
r <- receive sock 4096 mempty
74+
print r
75+
go r
76+
where
77+
decoder = runGetIncremental decodeServerMessage
78+
go str = case pushChunk decoder str of
79+
Done rest _ v -> do
80+
print v
81+
unless (B.null rest) $ go rest
82+
Partial _ -> error "Partial"
83+
Fail _ _ e -> error e
84+
85+
sendQuery :: Connection -> IO ()
86+
sendQuery (Connection s _) = do
87+
sendMessage s $ encodeClientMessage $ Parse "test" "SELECT $1 + $2" [23, 23]
88+
sendMessage s $ encodeClientMessage $
89+
Bind "test" "test" Text ["2", "3"] Text
90+
sendMessage s $ encodeClientMessage $ Execute "test"
91+
sendMessage s $ encodeClientMessage Sync
92+
93+
test :: IO ()
94+
test = do
95+
c <- connect defaultConnectionSettings
96+
sendQuery c
97+
threadDelay 3000
98+
close c
99+

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ decodeServerMessage = do
4848
getByteString (fromIntegral $ len - 4)
4949
pure $ ErrorResponse Nothing
5050
'n' -> pure NoData
51+
-- TODO
5152
'N' -> do
5253
getByteString (fromIntegral $ len - 4)
5354
pure $ NoticeResponse Nothing

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -74,8 +74,8 @@ encodeClientMessage Terminate
7474
= prependHeader 'X' mempty
7575

7676
encodeFormat :: Format -> Builder
77-
encodeFormat Text = int32BE 0
78-
encodeFormat Binary = int32BE 1
77+
encodeFormat Text = int16BE 0
78+
encodeFormat Binary = int16BE 1
7979

8080
----------
8181
-- Utils

0 commit comments

Comments
 (0)
0