Moved Parser to separate module

This commit is contained in:
VyacheslavHashov 2017-02-25 19:45:12 +03:00
parent a5a3f7c927
commit 5bd2b342e3
7 changed files with 193 additions and 184 deletions

View File

@ -28,6 +28,7 @@ library
, Database.PostgreSQL.Protocol.Types
, Database.PostgreSQL.Protocol.Encoders
, Database.PostgreSQL.Protocol.Decoders
, Database.PostgreSQL.Protocol.Parsers
, Database.PostgreSQL.Protocol.ExtractDataRows
, Database.PostgreSQL.Protocol.Store.Encode
, Database.PostgreSQL.Protocol.Store.Decode
@ -38,7 +39,6 @@ library
, socket
, socket-unix
, vector
, binary
, safe
, time
, hashable

View File

@ -39,6 +39,7 @@ import qualified Data.ByteString.Char8 as BS(pack, unpack)
import Database.PostgreSQL.Protocol.Encoders
import Database.PostgreSQL.Protocol.Decoders
import Database.PostgreSQL.Protocol.Parsers
import Database.PostgreSQL.Protocol.ExtractDataRows
import Database.PostgreSQL.Protocol.Types
import Database.PostgreSQL.Protocol.Store.Encode (runEncode, Encode)

View File

@ -1,55 +1,55 @@
module Database.PostgreSQL.Protocol.Codecs.Decoders where
import Data.Bool
import Data.Word
import Data.Int
import Data.Char
import Control.Monad
import qualified Data.ByteString as B
import qualified Data.Vector as V
import Database.PostgreSQL.Protocol.Store.Decode
import Database.PostgreSQL.Protocol.Store.Encode
import Database.PostgreSQL.Protocol.Types
{-# INLINE skipHeader #-}
skipHeader :: Decode ()
skipHeader = skipBytes 7
skipDataRowHeader :: Decode ()
skipDataRowHeader = skipBytes 7
{-# INLINE getNullable #-}
getNullable :: Decode a -> Decode (Maybe a)
fieldLength :: Decode Int
fieldLength = fromIntegral <$> getInt32BE
getNonNullable :: FieldDecoder a -> Decode a
getNonNullable dec = fieldLength >>= runFieldDecoder dec
getNullable :: FieldDecoder a -> Decode (Maybe a)
getNullable dec = do
len <- getInt32BE
len <- fieldLength
if len == -1
then pure Nothing
else Just <$!> dec
else Just <$!> runFieldDecoder dec len
{-# INLINE getString #-}
getString :: Decode (Maybe B.ByteString)
getString = getInt32BE >>= (Just <$!>) . getByteString . fromIntegral
-- Field in composites Oid before value
compositeValue :: Decode a -> Decode a
compositeValue dec = skipBytes 4 >> dec
{-# INLINE getBool #-}
getBool :: Decode Bool
getBool = (== 1) <$> getWord8
compositeHeader :: Decode ()
compositeHeader = skipBytes 4
{-# INLINE getCh #-}
getCh :: Decode Char
getCh = (chr . fromIntegral) <$> getWord8
arrayData :: Int -> Decode a -> Decode (V.Vector a)
arrayData len dec = undefined
-- Public decoders
-- | Decodes only content of a field.
newtype FieldDecoder a = FieldDecoder { runFieldDecoder :: Int -> Decode a }
getCustom :: Decode (Maybe B.ByteString, Maybe Int32, Maybe Int32,
Maybe Int16, Maybe Bool, Maybe Char, Maybe Bool,
Maybe Bool, Maybe Char, Maybe Int32, Maybe Int32,
Maybe Int32)
getCustom = (,,,,,,,,,,,) <$>
getString <*>
(getNullable getInt32BE) <*>
(getNullable getInt32BE) <*>
(getNullable getInt16BE) <*>
(getNullable getBool) <*>
(getNullable getCh) <*>
(getNullable getBool) <*>
(getNullable getBool) <*>
(getNullable getCh) <*>
(getNullable getInt32BE) <*>
(getNullable getInt32BE) <*>
(getNullable getInt32BE)
int2 :: FieldDecoder Int16
int2 = FieldDecoder $ \ _ -> getInt16BE
getCustomRow = skipHeader *> getCustom
int4 :: FieldDecoder Int32
int4 = FieldDecoder $ \ _ -> getInt32BE
int8 :: FieldDecoder Int64
int8 = FieldDecoder $ \ _ -> getInt64BE
bool :: FieldDecoder Bool
bool = FieldDecoder $ \ _ -> (== 1) <$> getWord8

View File

@ -1,5 +1,3 @@
{-# language RecordWildCards #-}
module Database.PostgreSQL.Protocol.Decoders
(
-- * High-lever decoder
@ -8,24 +6,16 @@ module Database.PostgreSQL.Protocol.Decoders
, decodeAuthResponse
, decodeHeader
, decodeServerMessage
-- * Helpers
, parseServerVersion
, parseIntegerDatetimes
, parseErrorDesc
) where
import Data.Monoid ((<>))
import Data.Maybe (fromMaybe)
import Data.Char (chr)
import Data.Word (Word8, Word16, Word32)
import Text.Read (readMaybe)
import qualified Data.Vector as V
import qualified Data.ByteString as B
import Data.ByteString.Char8 as BS(readInteger, readInt, unpack, pack)
import qualified Data.HashMap.Strict as HM
import Data.ByteString.Char8 as BS(unpack)
import Database.PostgreSQL.Protocol.Types
import Database.PostgreSQL.Protocol.Store.Decode
import Database.PostgreSQL.Protocol.Parsers
-- | Parses and dispatches all server messages except `DataRow`.
decodeNextServerMessage
@ -139,141 +129,6 @@ decodeFormat = getInt16BE >>= \f ->
1 -> pure Binary
_ -> fail "Unknown field format"
-----------------------------
-- Helper parsers that work with B.ByteString, not Decode type
-- Helper to parse, not used by decoder itself
parseServerVersion :: B.ByteString -> Either B.ByteString ServerVersion
parseServerVersion bs =
let (numbersStr, desc) = B.span isDigitDot bs
numbers = readMaybe . BS.unpack <$> B.split 46 numbersStr
in case numbers ++ repeat (Just 0) of
(Just major : Just minor : Just rev : _) ->
Right $ ServerVersion major minor rev desc
_ -> Left $ "Unknown server version" <> bs
where
isDigitDot c | c == 46 = True -- dot
| c >= 48 && c < 58 = True -- digits
| otherwise = False
-- Helper to parse, not used by decoder itself
parseIntegerDatetimes :: B.ByteString -> Either B.ByteString Bool
parseIntegerDatetimes bs
| bs == "on" || bs == "yes" || bs == "1" = Right True
| otherwise = Right False
parseCommandResult :: B.ByteString -> Either B.ByteString CommandResult
parseCommandResult s =
let (command, rest) = B.break (== space) s
in case command of
-- format: `INSERT oid rows`
"INSERT" ->
maybe (Left "Invalid format in INSERT command result") Right $ do
(oid, r) <- readInteger $ B.dropWhile (== space) rest
(rows, _) <- readInteger $ B.dropWhile (== space) r
Just $ InsertCompleted (Oid $ fromInteger oid)
(RowsCount $ fromInteger rows)
"DELETE" -> DeleteCompleted <$> readRows rest
"UPDATE" -> UpdateCompleted <$> readRows rest
"SELECT" -> SelectCompleted <$> readRows rest
"MOVE" -> MoveCompleted <$> readRows rest
"FETCH" -> FetchCompleted <$> readRows rest
"COPY" -> CopyCompleted <$> readRows rest
_ -> Right CommandOk
where
space = 32
readRows = maybe (Left "Invalid rows format in command result")
(pure . RowsCount . fromInteger . fst)
. readInteger . B.dropWhile (== space)
parseErrorNoticeFields
:: B.ByteString -> Either B.ByteString (HM.HashMap Char B.ByteString)
parseErrorNoticeFields = Right . HM.fromList
. fmap (\s -> (chr . fromIntegral $ B.head s, B.tail s))
. filter (not . B.null) . B.split 0
parseErrorSeverity :: B.ByteString -> Either B.ByteString ErrorSeverity
parseErrorSeverity bs = Right $ case bs of
"ERROR" -> SeverityError
"FATAL" -> SeverityFatal
"PANIC" -> SeverityPanic
_ -> UnknownErrorSeverity
parseNoticeSeverity :: B.ByteString -> Either B.ByteString NoticeSeverity
parseNoticeSeverity bs = Right $ case bs of
"WARNING" -> SeverityWarning
"NOTICE" -> SeverityNotice
"DEBUG" -> SeverityDebug
"INFO" -> SeverityInfo
"LOG" -> SeverityLog
_ -> UnknownNoticeSeverity
parseErrorDesc :: B.ByteString -> Either B.ByteString ErrorDesc
parseErrorDesc s = do
hm <- parseErrorNoticeFields s
errorSeverityOld <- lookupKey 'S' hm
errorCode <- lookupKey 'C' hm
errorMessage <- lookupKey 'M' hm
-- This is identical to the S field except that the contents are
-- never localized. This is present only in messages generated by
-- PostgreSQL versions 9.6 and later.
let errorSeverityNew = HM.lookup 'V' hm
errorSeverity <- parseErrorSeverity $
fromMaybe errorSeverityOld errorSeverityNew
let
errorDetail = HM.lookup 'D' hm
errorHint = HM.lookup 'H' hm
errorPosition = HM.lookup 'P' hm >>= fmap fst . readInt
errorInternalPosition = HM.lookup 'p' hm >>= fmap fst . readInt
errorInternalQuery = HM.lookup 'q' hm
errorContext = HM.lookup 'W' hm
errorSchema = HM.lookup 's' hm
errorTable = HM.lookup 't' hm
errorColumn = HM.lookup 'c' hm
errorDataType = HM.lookup 'd' hm
errorConstraint = HM.lookup 'n' hm
errorSourceFilename = HM.lookup 'F' hm
errorSourceLine = HM.lookup 'L' hm >>= fmap fst . readInt
errorSourceRoutine = HM.lookup 'R' hm
Right ErrorDesc{..}
where
lookupKey c = maybe (Left $ "Neccessary key " <> BS.pack (show c) <>
"is not presented in ErrorResponse message")
Right . HM.lookup c
parseNoticeDesc :: B.ByteString -> Either B.ByteString NoticeDesc
parseNoticeDesc s = do
hm <- parseErrorNoticeFields s
noticeSeverityOld <- lookupKey 'S' hm
noticeCode <- lookupKey 'C' hm
noticeMessage <- lookupKey 'M' hm
-- This is identical to the S field except that the contents are
-- never localized. This is present only in messages generated by
-- PostgreSQL versions 9.6 and later.
let noticeSeverityNew = HM.lookup 'V' hm
noticeSeverity <- parseNoticeSeverity $
fromMaybe noticeSeverityOld noticeSeverityNew
let
noticeDetail = HM.lookup 'D' hm
noticeHint = HM.lookup 'H' hm
noticePosition = HM.lookup 'P' hm >>= fmap fst . readInt
noticeInternalPosition = HM.lookup 'p' hm >>= fmap fst . readInt
noticeInternalQuery = HM.lookup 'q' hm
noticeContext = HM.lookup 'W' hm
noticeSchema = HM.lookup 's' hm
noticeTable = HM.lookup 't' hm
noticeColumn = HM.lookup 'c' hm
noticeDataType = HM.lookup 'd' hm
noticeConstraint = HM.lookup 'n' hm
noticeSourceFilename = HM.lookup 'F' hm
noticeSourceLine = HM.lookup 'L' hm >>= fmap fst . readInt
noticeSourceRoutine = HM.lookup 'R' hm
Right NoticeDesc{..}
where
lookupKey c = maybe (Left $ "Neccessary key " <> BS.pack (show c) <>
"is not presented in NoticeResponse message")
Right . HM.lookup c
-- | Helper to lift Either in Decode
eitherToDecode :: Either B.ByteString a -> Decode a
eitherToDecode = either (fail . BS.unpack) pure

View File

@ -11,7 +11,7 @@ import qualified Data.ByteString.Lazy.Internal as BL
import Database.PostgreSQL.Driver.Error
import Database.PostgreSQL.Protocol.Types
import Database.PostgreSQL.Protocol.Decoders
import Database.PostgreSQL.Protocol.Parsers
import Database.PostgreSQL.Protocol.Utils
-- Optimized loop for extracting chunks of DataRows.

View File

@ -0,0 +1,153 @@
{-# language RecordWildCards #-}
-- Helper parser that works with ByteString,
-- not Decode
module Database.PostgreSQL.Protocol.Parsers
( parseServerVersion
, parseIntegerDatetimes
, parseErrorDesc
, parseNoticeDesc
, parseCommandResult
) where
import Data.Monoid ((<>))
import Data.Char (chr)
import Data.Maybe (fromMaybe)
import qualified Data.ByteString as B
import Data.ByteString.Char8 as BS(readInteger, readInt, unpack, pack)
import Text.Read (readMaybe)
import qualified Data.HashMap.Strict as HM
import Database.PostgreSQL.Protocol.Types
-- Helper to parse
parseServerVersion :: B.ByteString -> Either B.ByteString ServerVersion
parseServerVersion bs =
let (numbersStr, desc) = B.span isDigitDot bs
numbers = readMaybe . BS.unpack <$> B.split 46 numbersStr
in case numbers ++ repeat (Just 0) of
(Just major : Just minor : Just rev : _) ->
Right $ ServerVersion major minor rev desc
_ -> Left $ "Unknown server version" <> bs
where
isDigitDot c | c == 46 = True -- dot
| c >= 48 && c < 58 = True -- digits
| otherwise = False
-- Helper to parse
parseIntegerDatetimes :: B.ByteString -> Either B.ByteString Bool
parseIntegerDatetimes bs
| bs == "on" || bs == "yes" || bs == "1" = Right True
| otherwise = Right False
parseCommandResult :: B.ByteString -> Either B.ByteString CommandResult
parseCommandResult s =
let (command, rest) = B.break (== space) s
in case command of
-- format: `INSERT oid rows`
"INSERT" ->
maybe (Left "Invalid format in INSERT command result") Right $ do
(oid, r) <- readInteger $ B.dropWhile (== space) rest
(rows, _) <- readInteger $ B.dropWhile (== space) r
Just $ InsertCompleted (Oid $ fromInteger oid)
(RowsCount $ fromInteger rows)
"DELETE" -> DeleteCompleted <$> readRows rest
"UPDATE" -> UpdateCompleted <$> readRows rest
"SELECT" -> SelectCompleted <$> readRows rest
"MOVE" -> MoveCompleted <$> readRows rest
"FETCH" -> FetchCompleted <$> readRows rest
"COPY" -> CopyCompleted <$> readRows rest
_ -> Right CommandOk
where
space = 32
readRows = maybe (Left "Invalid rows format in command result")
(pure . RowsCount . fromInteger . fst)
. readInteger . B.dropWhile (== space)
parseErrorNoticeFields
:: B.ByteString -> Either B.ByteString (HM.HashMap Char B.ByteString)
parseErrorNoticeFields = Right . HM.fromList
. fmap (\s -> (chr . fromIntegral $ B.head s, B.tail s))
. filter (not . B.null) . B.split 0
parseErrorSeverity :: B.ByteString -> Either B.ByteString ErrorSeverity
parseErrorSeverity bs = Right $ case bs of
"ERROR" -> SeverityError
"FATAL" -> SeverityFatal
"PANIC" -> SeverityPanic
_ -> UnknownErrorSeverity
parseNoticeSeverity :: B.ByteString -> Either B.ByteString NoticeSeverity
parseNoticeSeverity bs = Right $ case bs of
"WARNING" -> SeverityWarning
"NOTICE" -> SeverityNotice
"DEBUG" -> SeverityDebug
"INFO" -> SeverityInfo
"LOG" -> SeverityLog
_ -> UnknownNoticeSeverity
parseErrorDesc :: B.ByteString -> Either B.ByteString ErrorDesc
parseErrorDesc s = do
hm <- parseErrorNoticeFields s
errorSeverityOld <- lookupKey 'S' hm
errorCode <- lookupKey 'C' hm
errorMessage <- lookupKey 'M' hm
-- This is identical to the S field except that the contents are
-- never localized. This is present only in messages generated by
-- PostgreSQL versions 9.6 and later.
let errorSeverityNew = HM.lookup 'V' hm
errorSeverity <- parseErrorSeverity $
fromMaybe errorSeverityOld errorSeverityNew
let
errorDetail = HM.lookup 'D' hm
errorHint = HM.lookup 'H' hm
errorPosition = HM.lookup 'P' hm >>= fmap fst . readInt
errorInternalPosition = HM.lookup 'p' hm >>= fmap fst . readInt
errorInternalQuery = HM.lookup 'q' hm
errorContext = HM.lookup 'W' hm
errorSchema = HM.lookup 's' hm
errorTable = HM.lookup 't' hm
errorColumn = HM.lookup 'c' hm
errorDataType = HM.lookup 'd' hm
errorConstraint = HM.lookup 'n' hm
errorSourceFilename = HM.lookup 'F' hm
errorSourceLine = HM.lookup 'L' hm >>= fmap fst . readInt
errorSourceRoutine = HM.lookup 'R' hm
Right ErrorDesc{..}
where
lookupKey c = maybe (Left $ "Neccessary key " <> BS.pack (show c) <>
"is not presented in ErrorResponse message")
Right . HM.lookup c
parseNoticeDesc :: B.ByteString -> Either B.ByteString NoticeDesc
parseNoticeDesc s = do
hm <- parseErrorNoticeFields s
noticeSeverityOld <- lookupKey 'S' hm
noticeCode <- lookupKey 'C' hm
noticeMessage <- lookupKey 'M' hm
-- This is identical to the S field except that the contents are
-- never localized. This is present only in messages generated by
-- PostgreSQL versions 9.6 and later.
let noticeSeverityNew = HM.lookup 'V' hm
noticeSeverity <- parseNoticeSeverity $
fromMaybe noticeSeverityOld noticeSeverityNew
let
noticeDetail = HM.lookup 'D' hm
noticeHint = HM.lookup 'H' hm
noticePosition = HM.lookup 'P' hm >>= fmap fst . readInt
noticeInternalPosition = HM.lookup 'p' hm >>= fmap fst . readInt
noticeInternalQuery = HM.lookup 'q' hm
noticeContext = HM.lookup 'W' hm
noticeSchema = HM.lookup 's' hm
noticeTable = HM.lookup 't' hm
noticeColumn = HM.lookup 'c' hm
noticeDataType = HM.lookup 'd' hm
noticeConstraint = HM.lookup 'n' hm
noticeSourceFilename = HM.lookup 'F' hm
noticeSourceLine = HM.lookup 'L' hm >>= fmap fst . readInt
noticeSourceRoutine = HM.lookup 'R' hm
Right NoticeDesc{..}
where
lookupKey c = maybe (Left $ "Neccessary key " <> BS.pack (show c) <>
"is not presented in NoticeResponse message")
Right . HM.lookup c

View File

@ -6,7 +6,7 @@ import Test.Tasty
import Test.Tasty.HUnit
import Database.PostgreSQL.Protocol.Types
import Database.PostgreSQL.Protocol.Decoders
import Database.PostgreSQL.Protocol.Parsers
testMisc :: TestTree