8000 Moved Parser to separate module · postgres-haskell/postgres-wire@5bd2b34 · GitHub
[go: up one dir, main page]
Skip to content

Commit 5bd2b34

Browse files
VyacheslavHashovVyacheslavHashov
committed
Moved Parser to separate module
1 parent a5a3f7c commit 5bd2b34

File tree

7 files changed

+199
-190
lines changed

7 files changed

+199
-190
lines changed

‎postgres-wire.cabal

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ library
2828
, Database.PostgreSQL.Protocol.Types
2929
, Database.PostgreSQL.Protocol.Encoders
3030
, Database.PostgreSQL.Protocol.Decoders
31+
, Database.PostgreSQL.Protocol.Parsers
3132
, Database.PostgreSQL.Protocol.ExtractDataRows
3233
, Database.PostgreSQL.Protocol.Store.Encode
3334
, Database.PostgreSQL.Protocol.Store.Decode
@@ -38,7 +39,6 @@ library
3839
, socket
3940
, socket-unix
4041
, vector
41-
, binary
4242
, safe
4343
, time
4444
, hashable

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ import qualified Data.ByteString.Char8 as BS(pack, unpack)
3939

4040
import Database.PostgreSQL.Protocol.Encoders
4141
import Database.PostgreSQL.Protocol.Decoders
42+
import Database.PostgreSQL.Protocol.Parsers
4243
import Database.PostgreSQL.Protocol.ExtractDataRows
4344
import Database.PostgreSQL.Protocol.Types
4445
import Database.PostgreSQL.Protocol.Store.Encode (runEncode, Encode)

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

Lines changed: 40 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -1,55 +1,55 @@
11
module Database.PostgreSQL.Protocol.Codecs.Decoders where
22

3+
import Data.Bool
34
import Data.Word
45
import Data.Int
56
import Data.Char
67
import Control.Monad
78
import qualified Data.ByteString as B
9+
import qualified Data.Vector as V
810

911
import Database.PostgreSQL.Protocol.Store.Decode
12+
import Database.PostgreSQL.Protocol.Store.Encode
13+
import Database.PostgreSQL.Protocol.Types
1014

11-
{-# INLINE skipHeader #-}
12-
skipHeader :: Decode ()
13-
skipHeader = skipBytes 7
15+
skipDataRowHeader :: Decode ()
16+
skipDataRowHeader = skipBytes 7
1417

15-
{-# INLINE getNullable #-}
16-
getNullable :: Decode a -> Decode (Maybe a)
18+
fieldLength :: Decode Int
19+
fieldLength = fromIntegral <$> getInt32BE
20+
21+
getNonNullable :: FieldDecoder a -> Decode a
22+
getNonNullable dec = fieldLength >>= runFieldDecoder dec
23+
24+
getNullable :: FieldDecoder a -> Decode (Maybe a)
1725
getNullable dec = do
18-
len <- getInt32BE
26+
len <- fieldLength
1927
if len == -1
2028
then pure Nothing
21-
else Just <$!> dec
22-
23-
{-# INLINE getString #-}
24-
getString :: Decode (Maybe B.ByteString)
25-
getString = getInt32BE >>= (Just <$!>) . getByteString . fromIntegral
26-
27-
{-# INLINE getBool #-}
28-
getBool :: Decode Bool
29-
getBool = (== 1) <$> getWord8
30-
31-
{-# INLINE getCh #-}
32-
getCh :: Decode Char
33-
getCh = (chr . fromIntegral) <$> getWord8
34-
35-
36-
getCustom :: Decode (Maybe B.ByteString, Maybe Int32, Maybe Int32,
37-
Maybe Int16, Maybe Bool, Maybe Char, Maybe Bool,
38-
Maybe Bool, Maybe Char, Maybe Int32, Maybe Int32,
39-
Maybe Int32)
40-
getCustom = (,,,,,,,,,,,) <$>
41-
getString <*>
42-
(getNullable getInt32BE) <*>
43-
(getNullable getInt32BE) <*>
44-
(getNullable getInt16BE) <*>
45-
(getNullable getBool) <*>
46-
(getNullable getCh) <*>
47-
(getNullable getBool) <*>
48-
(getNullable getBool) <*>
49-
(getNullable getCh) <*>
50-
(getNullable getInt32BE) <*>
51-
(getNullable getInt32BE) <*>
52-
(getNullable getInt32BE)
53-
54-
getCustomRow = skipHeader *> getCustom
29+
else Just <$!> runFieldDecoder dec len
30+
31+
-- Field in composites Oid before value
32+
compositeValue :: Decode a -> Decode a
33+
compositeValue dec = skipBytes 4 >> dec
34+
35+
compositeHeader :: Decode ()
36+
compositeHeader = skipBytes 4
37+
38+
arrayData :: Int -> Decode a -> Decode (V.Vector a)
39+
arrayData len dec = undefined
40+
41+
-- Public decoders
42+
-- | Decodes only content of a field.
43+
newtype FieldDecoder a = FieldDecoder { runFieldDecoder :: Int -> Decode a }
44+
45+
int2 :: FieldDecoder Int16
46+
int2 = FieldDecoder $ \ _ -> getInt16BE
47+
48+
int4 :: FieldDecoder Int32
49+
int4 = FieldDecoder $ \ _ -> getInt32BE
50+
51+
int8 :: FieldDecoder Int64
52+
int8 = FieldDecoder $ \ _ -> getInt64BE
5553

54+
bool :: FieldDecoder Bool
55+
bool = FieldDecoder $ \ _ -> (== 1) <$> getWord8

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

Lines changed: 2 additions & 147 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,3 @@
1-
{-# language RecordWildCards #-}
2-
31
module Database.PostgreSQL.Protocol.Decoders
42
(
53
-- * High-lever decoder
@@ -8,24 +6,16 @@ module Database.PostgreSQL.Protocol.Decoders
86
, decodeAuthResponse
97
, decodeHeader
108
, decodeServerMessage
11-
-- * Helpers
12-
, parseServerVersion
13-
, parseIntegerDatetimes
14-
, parseErrorDesc
159
) where
1610

17-
import Data.Monoid ((<>))
18-
import Data.Maybe (fromMaybe)
1911
import Data.Char (chr)
20-
import Data.Word (Word8, Word16, Word32)
21-
import Text.Read (readMaybe)
2212
import qualified Data.Vector as V
2313
import qualified Data.ByteString as B
24-
import Data.ByteString.Char8 as BS(readInteger, readInt, unpack, pack)
25-
import qualified Data.HashMap.Strict as HM
14+
import Data.ByteString.Char8 as BS(unpack)
2615

2716
import Database.PostgreSQL.Protocol.Types
2817
import Database.PostgreSQL.Protocol.Store.Decode
18+
import Database.PostgreSQL.Protocol.Parsers
2919

3020
-- | Parses and dispatches all server messages except `DataRow`.
3121
decodeNextServerMessage
@@ -139,141 +129,6 @@ decodeFormat = getInt16BE >>= \f ->
139129
1 -> pure Binary
140130
_ -> fail "Unknown field format"
141131

142-
-----------------------------
143-
-- Helper parsers that work with B.ByteString, not Decode type
144-
145-
-- Helper to parse, not used by decoder itself
146-
parseServerVersion :: B.ByteString -> Either B.ByteString ServerVersion
147-
parseServerVersion bs =
148-
let (numbersStr, desc) = B.span isDigitDot bs
149-
numbers = readMaybe . BS.unpack <$> B.split 46 numbersStr
150-
in case numbers ++ repeat (Just 0) of
151-
(Just major : Just minor : Just rev : _) ->
152-
Right $ ServerVersion major minor rev desc
153-
_ -> Left $ "Unknown server version" <> bs
154-
where
155-
isDigitDot c | c == 46 = True -- dot
156-
| c >= 48 && c < 58 = True -- digits
157-
| otherwise = False
158-
159-
-- Helper to parse, not used by decoder itself
160-
parseIntegerDatetimes :: B.ByteString -> Either B.ByteString Bool
161-
parseIntegerDatetimes bs
162-
| bs == "on" || bs == "yes" || bs == "1" = Right True
163-
| otherwise = Right False
164-
165-
parseCommandResult :: B.ByteString -> Either B.ByteString CommandResult
166-
parseCommandResult s =
167-
let (command, rest) = B.break (== space) s
168-
in case command of
169-
-- format: `INSERT oid rows`
170-
"INSERT" ->
171-
maybe (Left "Invalid format in INSERT command result") Right $ do
172-
(oid, r) <- readInteger $ B.dropWhile (== space) rest
173-
(rows, _) <- readInteger $ B.dropWhile (== space) r
174-
Just $ InsertCompleted (Oid $ fromInteger oid)
175-
(RowsCount $ fromInteger rows)
176-
"DELETE" -> DeleteCompleted <$> readRows rest
177-
"UPDATE" -> UpdateCompleted <$> readRows rest
178-
"SELECT" -> SelectCompleted <$> readRows rest
179-
"MOVE" -> MoveCompleted <$> readRows rest
180-
"FETCH" -> FetchCompleted <$> readRows rest
181-
"COPY" -> CopyCompleted <$> readRows rest
182-
_ -> Right CommandOk
183-
where
184-
space = 32
185-
readRows = maybe (Left "Invalid rows format in command result")
186-
(pure . RowsCount . fromInteger . fst)
187-
. readInteger . B.dropWhile (== space)
188-
189-
parseErrorNoticeFields
190-
:: B.ByteString -> Either B.ByteString (HM.HashMap Char B.ByteString)
191-
parseErrorNoticeFields = Right . HM.fromList
192-
. fmap (\s -> (chr . fromIntegral $ B.head s, B.tail s))
193-
. filter (not . B.null) . B.split 0
194-
195-
parseErrorSeverity :: B.ByteString -> Either B.ByteString ErrorSeverity
196-
parseErrorSeverity bs = Right $ case bs of
197-
"ERROR" -> SeverityError
198-
"FATAL" -> SeverityFatal
199-
"PANIC" -> SeverityPanic
200-
_ -> UnknownErrorSeverity
201-
202-
parseNoticeSeverity :: B.ByteString -> Either B.ByteString NoticeSeverity
203-
parseNoticeSeverity bs = Right $ case bs of
204-
"WARNING" -> SeverityWarning
205-
"NOTICE" -> SeverityNotice
206-
"DEBUG" -> SeverityDebug
207-
"INFO" -> SeverityInfo
208-
"LOG" -> SeverityLog
209-
_ -> UnknownNoticeSeverity
210-
211-
parseErrorDesc :: B.ByteString -> Either B.ByteString ErrorDesc
212-
parseErrorDesc s = do
213-
hm <- parseErrorNoticeFields s
214-
errorSeverityOld <- lookupKey 'S' hm
215-
errorCode <- lookupKey 'C' hm
216-
errorMessage <- lookupKey 'M' hm
217-
-- This is identical to the S field except that the contents are
218-
-- never localized. This is present only in messages generated by
219-
-- PostgreSQL versions 9.6 and later.
220-
let errorSeverityNew = HM.lookup 'V' hm
221-
errorSeverity <- parseErrorSeverity $
222-
fromMaybe errorSeverityOld errorSeverityNew
223-
let
224-
errorDetail = HM.lookup 'D' hm
225-
errorHint = HM.lookup 'H' hm
226-
errorPosition = HM.lookup 'P' hm >>= fmap fst . readInt
227-
errorInternalPosition = HM.lookup 'p' hm >>= fmap fst . readInt
228-
errorInternalQuery = HM.lookup 'q' hm
229-
errorContext = HM.lookup 'W' hm
230-
errorSchema = HM.lookup 's' hm
231-
errorTable = HM.lookup 't' hm
232-
errorColumn = HM.lookup 'c' hm
233-
errorDataType = HM.lookup 'd' hm
234-
errorConstraint = HM.lookup 'n' hm
235-
errorSourceFilename = HM.lookup 'F' hm
236-
errorSourceLine = HM.lookup 'L' hm >>= fmap fst . readInt
237-
errorSourceRoutine = HM.lookup 'R' hm
238-
Right ErrorDesc{..}
239-
where
240-
lookupKey c = maybe (Left $ "Neccessary key " <> BS.pack (show c) <>
241-
"is not presented in ErrorResponse message")
242-
Right . HM.lookup c
243-
244-
parseNoticeDesc :: B.ByteString -> Either B.ByteString NoticeDesc
245-
parseNoticeDesc s = do
246-
hm <- parseErrorNoticeFields s
247-
noticeSeverityOld <- lookupKey 'S' hm
248-
noticeCode <- lookupKey 'C' hm
249-
noticeMessage <- lookupKey 'M' hm
250-
-- This is identical to the S field except that the contents are
251-
-- never localized. This is present only in messages generated by
252-
-- PostgreSQL versions 9.6 and later.
253-
let noticeSeverityNew = HM.lookup 'V' hm
254-
noticeSeverity <- parseNoticeSeverity $
255-
fromMaybe noticeSeverityOld noticeSeverityNew
256-
let
257-
noticeDetail = HM.lookup 'D' hm
258-
noticeHint = HM.lookup 'H' hm
259-
noticePosition = HM.lookup 'P' hm >>= fmap fst . readInt
260-
noticeInternalPosition = HM.lookup 'p' hm >>= fmap fst . readInt
261-
noticeInternalQuery = HM.lookup 'q' hm
262-
noticeContext = HM.lookup 'W' hm
263-
noticeSchema = HM.lookup 's' hm
264-
noticeTable = HM.lookup 't' hm
265-
noticeColumn = HM.lookup 'c' hm
266-
noticeDataType = HM.lookup 'd' hm
267-
noticeConstraint = HM.lookup 'n' hm
268-
noticeSourceFilename = HM.lookup 'F' hm
269-
noticeSourceLine = HM.lookup 'L' hm >>= fmap fst . readInt
270-
noticeSourceRoutine = HM.lookup 'R' hm
271-
Right NoticeDesc{..}
272-
where
273-
lookupKey c = maybe (Left $ "Neccessary key " <> BS.pack (show c) <>
274-
"is not presented in NoticeResponse message")
275-
Right . HM.lookup c
276-
277132
-- | Helper to lift Either in Decode
278133
eitherToDecode :: Either B.ByteString a -> Decode a
279134
eitherToDecode = either (fail . BS.unpack) pure

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ import qualified Data.ByteString.Lazy.Internal as BL
1111

1212
import Database.PostgreSQL.Driver.Error
1313
import Database.PostgreSQL.Protocol.Types
14-
import Database.PostgreSQL.Protocol.Decoders
14+
import Database.PostgreSQL.Protocol.Parsers
1515
import Database.PostgreSQL.Protocol.Utils
1616

1717
-- Optimized loop for extracting chunks of DataRows.

0 commit comments

Comments
 (0)
0