8000 Encoders based on store · postgres-haskell/postgres-wire@514507b · GitHub
[go: up one dir, main page]
Skip to content

Commit 514507b

Browse files
VyacheslavHashovVyacheslavHashov
committed
Encoders based on store
1 parent c966eb5 commit 514507b

File tree

3 files changed

+47
-46
lines changed

3 files changed

+47
-46
lines changed

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ import Crypto.Hash (hash, Digest, MD5)
2222
import Database.PostgreSQL.Protocol.Encoders
2323
import Database.PostgreSQL.Protocol.Decoders
2424
import Database.PostgreSQL.Protocol.Types
25+
import Database.PostgreSQL.Protocol.Store (runEncode)
2526

2627
import Database.PostgreSQL.Driver.Settings
2728
import Database.PostgreSQL.Driver.StatementStorage
@@ -313,12 +314,12 @@ defaultFilter msg = case msg of
313314

314315
sendStartMessage :: RawConnection -> StartMessage -> IO ()
315316
sendStartMessage rawConn msg = void $ do
316-
let smsg = toStrict . toLazyByteString $ encodeStartMessage msg
317+
let smsg = runEncode $ encodeStartMessage msg
317318
rSend rawConn smsg
318319

319320
sendMessage :: RawConnection -> ClientMessage -> IO ()
320321
sendMessage rawConn msg = void $ do
321-
let smsg = toStrict . toLazyByteString $ encodeClientMessage msg
322+
let smsg = runEncode $ encodeClientMessage msg
322323
rSend rawConn smsg
323324

324325
withConnectionMode

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

Lines changed: 38 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -3,99 +3,93 @@ module Database.PostgreSQL.Protocol.Encoders where
33
import Data.Word
44
import Data.Int
55
import Data.Monoid
6-
import Data.ByteString.Lazy as BL
7-
import Data.ByteString.Builder
86
import Data.Foldable
97
import qualified Data.Vector as V
108
import qualified Data.ByteString as B
119

1210
import Database.PostgreSQL.Protocol.Types
11+
import Database.PostgreSQL.Protocol.Store
1312

1413
-- | Protocol Version 3.0, major version in the first word16.
1514
currentVersion :: Int32
1615
currentVersion = 3 * 256 * 256
1716

18-
encodeStartMessage :: StartMessage -> Builder
17+
encodeStartMessage :: StartMessage -> Encode
1918
encodeStartMessage (StartupMessage (Username uname) (DatabaseName dbname))
20-
= int32BE (len + 4) <> payload
19+
= putInt32BE (len + 4) <> payload
2120
where
22-
len = fromIntegral $ BL.length $ toLazyByteString payload
23-
payload = int32BE currentVersion <>
24-
pgString "user" <> pgString uname <>
25-
pgString "database" <> pgString dbname <> word8 0
21+
len = fromIntegral $ getEncodeLen payload
22+
payload = putInt32BE currentVersion <>
23+
putPgString "user" <> putPgString uname <>
24+
putPgString "database" <> putPgString dbname <> putWord8 0
2625
encodeStartMessage SSLRequest
27-
= int32BE 8 <> int32BE 80877103 -- value hardcoded by PostgreSQL docs.
26+
= putInt32BE 8 <> putInt32BE 80877103 -- value hardcoded by PostgreSQL docs.
2827

29-
encodeClientMessage :: ClientMessage -> Builder
28+
encodeClientMessage :: ClientMessage -> Encode
3029
encodeClientMessage (Bind (PortalName portalName) (StatementName stmtName)
3130
paramFormat values resultFormat)
3231
= prependHeader 'B' $
33-
pgString portalName <>
34-
pgString stmtName <>
32+
putPgString portalName <>
33+
putPgString stmtName <>
3534
-- `1` means that the specified format code is applied to all parameters
36-
int16BE 1 <>
35+
putInt16BE 1 <>
3736
encodeFormat paramFormat <>
38-
int16BE (fromIntegral $ V.length values) <>
37+
putInt16BE (fromIntegral $ V.length values) <>
3938
fold (encodeValue <$> values) <>
4039
-- `1` means that the specified format code is applied to all
4140
-- result columns (if any)
42-
int16BE 1 <>
41+
putInt16BE 1 <>
4342
encodeFormat resultFormat
4443
encodeClientMessage (CloseStatement (StatementName stmtName))
45-
= prependHeader 'C' $ char8 'S' <> pgString stmtName
44+
= prependHeader 'C' $ putChar8 'S' <> putPgString stmtName
4645
encodeClientMessage (ClosePortal (PortalName portalName))
47-
= prependHeader 'C' $ char8 'P' <> pgString portalName
46+
= prependHeader 'C' $ putChar8 'P' <> putPgString portalName
4847
encodeClientMessage (DescribeStatement (StatementName stmtName))
49-
= prependHeader 'D' $ char8 'S' <> pgString stmtName
48+
= prependHeader 'D' $ putChar8 'S' <> putPgString stmtName
5049
encodeClientMessage (DescribePortal (PortalName portalName))
51-
= prependHeader 'D' $ char8 'P' <> pgString portalName
50+
= prependHeader 'D' $ putChar8 'P' <> putPgString portalName
5251
encodeClientMessage (Execute (PortalName portalName) (RowsToReceive rows))
5352
= prependHeader 'E' $
54-
pgString portalName <>
55-
int32BE rows
53+
putPgString portalName <>
54+
putInt32BE rows
5655
encodeClientMessage Flush
5756
= prependHeader 'H' mempty
5857
encodeClientMessage (Parse (StatementName stmtName) (StatementSQL stmt) oids)
5958
= prependHeader 'P' $
60-
pgString stmtName <>
61-
pgString stmt <>
62-
int16BE (fromIntegral $ V.length oids) <>
63-
fold (int32BE . unOid <$> oids)
59+
putPgString stmtName <>
60+
putPgString stmt <>
61+
putInt16BE (fromIntegral $ V.length oids) <>
62+
fold (putInt32BE . unOid <$> oids)
6463
encodeClientMessage (PasswordMessage passtext)
65-
= prependHeader 'p' $ pgString $ getPassword passtext
64+
= prependHeader 'p' $ putPgString $ getPassword passtext
6665
where
6766
getPassword (PasswordPlain p) = p
6867
getPassword (PasswordMD5 p) = p
6968
encodeClientMessage (SimpleQuery (StatementSQL stmt))
70-
= prependHeader 'Q' $ pgString stmt
69+
= prependHeader 'Q' $ putPgString stmt
7170
encodeClientMessage Sync
7271
= prependHeader 'S' mempty
7372
encodeClientMessage Terminate
7473
= prependHeader 'X' mempty
7574

7675
-- Encodes single data values. Length `-1` indicates a NULL parameter value.
7776
-- No value bytes follow in the NULL case.
78-
encodeValue :: B.ByteString -> Builder
79-
encodeValue v | B.null v = int32BE (-1)
80-
| otherwise = int32BE (fromIntegral $ B.length v)
81-
<> byteString v
77+
encodeValue :: B.ByteString -> Encode
78+
encodeValue v | B.null v = putInt32BE (-1)
79+
| otherwise = putInt32BE (fromIntegral $ B.length v)
80+
<> putByteString v
8281

83-
encodeFormat :: Format -> Builder
84-
encodeFormat Text = int16BE 0
85-
encodeFormat Binary = int16BE 1
82+
encodeFormat :: Format -> Encode
83+
encodeFormat Text = putInt16BE 0
84+
encodeFormat Binary = putInt16BE 1
8685

8786
----------
8887
-- Utils
8988
---------
9089

91-
-- | C-like string
92-
pgString :: B.ByteString -> Builder
93-
pgString s = byteString s <> word8 0
94-
95-
prependHeader :: Char -> Builder -> Builder
96-
prependHeader c builder =
97-
let payload = toLazyByteString builder
98-
-- Length includes itself but not the first message-type byte
99-
len = 4 + fromIntegral (BL.length payload)
100-
in char8 c <> int32BE len <> lazyByteString payload
90+
prependHeader :: Char -> Encode -> Encode
91+
prependHeader c payload =
92+
-- Length includes itself but not the first message-type byte
93+
let len = 4 + fromIntegral (getEncodeLen payload)
94+
in putChar8 c <> putInt32BE len <> payload
10195

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

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ import qualified Data.Vector as V
66
import Data.Store.Core
77
import Data.Int (Int16, Int32)
88
import Data.Word (Word8)
9+
import Data.Char (ord)
910
import Foreign
1011
import Data.Monoid
1112
import Data.Foldable
@@ -17,6 +18,8 @@ instance Monoid Encode where
1718
mempty = Encode 0 . Poke $ \_ offset -> pure (offset, ())
1819
(Encode len1 f1) `mappend` (Encode len2 f2) = Encode (len1 + len2) (f1 *> f2)
1920

21+
getEncodeLen :: Encode -> Int
22+
getEncodeLen (Encode len _) = len
2023

2124
runEncode :: Encode -> B.ByteString
2225
runEncode (Encode len f) = unsafeEncodeWith f len
@@ -30,6 +33,9 @@ fixedPrim len f = Encode len . Poke $ \state offset -> do
3033
putWord8 :: Word8 -> Encode
3134
putWord8 w = fixedPrim 1 $ \p -> poke p w
3235

36+
putChar8 :: Char -> Encode
37+
putChar8 = putWord8 . fromIntegral . ord
38+
3339
putWord16BE :: Word16 -> Encode
3440
putWord16BE w = fixedPrim 2 $ \p -> do
3541
poke p (fromIntegral (shiftR w 8) :: Word8)

0 commit comments

Comments
 (0)
0