diff --git a/Text/ProtocolBuffers/Basic.hs b/Text/ProtocolBuffers/Basic.hs --- a/Text/ProtocolBuffers/Basic.hs +++ b/Text/ProtocolBuffers/Basic.hs @@ -9,6 +9,7 @@ , WireTag(..),FieldId(..),WireType(..),FieldType(..),EnumCode(..),WireSize -- * Some of the type classes implemented messages and fields , Mergeable(..),Default(..),Wire(..) + , isValidUTF8 ) where import Data.Binary.Put(Put) @@ -21,9 +22,10 @@ import Data.Monoid(Monoid(..)) import Data.Sequence(Seq) import Data.Typeable(Typeable(..)) -import Data.Word(Word32,Word64) +import Data.Word(Word8,Word32,Word64) import Text.ProtocolBuffers.Get(Get) +import qualified Data.ByteString.Lazy as L(unpack) import Data.ByteString.Lazy.UTF8 as U (toString,fromString) -- Num instances are derived below for the purpose of getting fromInteger for case matching @@ -197,3 +199,22 @@ wirePut :: FieldType -> b -> Put {-# INLINE wireGet #-} wireGet :: FieldType -> Get b + +-- Returns Nothing if valid, and the position of the error if invalid +isValidUTF8 :: ByteString -> Maybe Int +isValidUTF8 ws = go 0 (L.unpack ws) 0 where + go :: Int -> [Word8] -> Int -> Maybe Int + go 0 [] _ = Nothing + go 0 (x:xs) n | x <= 127 = go 0 xs $! succ n -- binary 01111111 + | x <= 193 = Just n -- binary 11000001, decodes to <=127, should not be here + | x <= 223 = go 1 xs $! succ n -- binary 11011111 + | x <= 239 = go 2 xs $! succ n -- binary 11101111 + | x <= 243 = go 3 xs $! succ n -- binary 11110011 + | x == 244 = high xs $! succ n -- binary 11110100 + | otherwise = Just n + go i (x:xs) n | 128 <= x && x <= 191 = go (pred i) xs $! succ n + go _ _ n = Just n + -- leading 3 bits are 100, so next 6 are at most 001111, i.e. 10001111 + high (x:xs) n | 128 <= x && x <= 143 = go 2 xs $! succ n + | otherwise = Just n + high [] n = Just n diff --git a/Text/ProtocolBuffers/Extensions.hs b/Text/ProtocolBuffers/Extensions.hs --- a/Text/ProtocolBuffers/Extensions.hs +++ b/Text/ProtocolBuffers/Extensions.hs @@ -22,14 +22,14 @@ -- * External types and classes , Key(..),ExtKey(..),MessageAPI(..) -- * Internal types, functions, and classes - , wireSizeExtField,wirePutExtField,getMessageExt,getBareMessageExt,loadExtension + , wireSizeExtField,wirePutExtField,loadExtension,notExtension , GPB,ExtField(..),ExtendMessage(..),ExtFieldValue(..) ) where +import Control.Monad.Error.Class(throwError) import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as F import Data.Generics -import Data.Ix(inRange) import Data.Map(Map) import qualified Data.Map as M import Data.Maybe(fromMaybe) @@ -538,28 +538,15 @@ aPut (fi,(ExtOptional ft (GPDyn GPWitness d))) = wirePutOpt (toWireTag fi ft) ft (Just d) aPut (fi,(ExtRepeated ft (GPDynSeq GPWitness s))) = wirePutRep (toWireTag fi ft) ft s --- | This is used by the generated code to get messages that have extensions -getMessageExt :: (Mergeable message, ReflectDescriptor message,Typeable message,ExtendMessage message) - => (FieldId -> message -> Get message) -- handles "allowed" wireTags - -> Get message -getMessageExt = getMessageWith loadExtension - --- | This is used by the generated code to get messages that have extensions -getBareMessageExt :: (Mergeable message, ReflectDescriptor message,Typeable message,ExtendMessage message) - => (FieldId -> message -> Get message) -- handles "allowed" wireTags - -> Get message -getBareMessageExt = getBareMessageWith loadExtension - --- | 'isValidExt' is used by 'extension' to check whether the field --- number is in one of the ranges declared in the '.proto' file. -{-# INLINE isValidExt #-} -isValidExt :: ExtendMessage a => FieldId -> a -> Bool -isValidExt fi msg = any (flip inRange fi) (validExtRanges msg) +notExtension :: (ReflectDescriptor a, ExtendMessage a,Typeable a) => FieldId -> WireType -> a -> Get a +notExtension fieldId _wireType msg = throwError ("Field id "++show fieldId++" is not a valid extension field id for "++show (typeOf (undefined `asTypeOf` msg))) -- | get a value from the wire into the message's ExtField. This is -- used by 'getMessageExt' and 'getBareMessageExt' above. loadExtension :: (ReflectDescriptor a, ExtendMessage a) => FieldId -> WireType -> a -> Get a -loadExtension fieldId wireType msg | isValidExt fieldId msg = do +--loadExtension fieldId wireType msg | isValidExt fieldId msg = do -- XXX +--loadExtension fieldId wireType msg = unknown fieldId wireType msg -- XXX +loadExtension fieldId wireType msg = do let (ExtField ef) = getExtField msg badwt wt = do here <- bytesRead fail $ "Conflicting wire types at byte position "++show here ++ " for extension to message: "++show (typeOf msg,fieldId,wireType,wt) @@ -587,7 +574,6 @@ let v' = ExtRepeated ft (GPDynSeq x (s |> a)) ef' = M.insert fieldId v' ef seq v' $ seq ef' $ return (putExtField (ExtField ef') msg) -loadExtension fieldId wireType msg = unknown fieldId wireType msg class MessageAPI msg a b | msg a -> b where -- | Access data in a message. The first argument is always the diff --git a/Text/ProtocolBuffers/Header.hs b/Text/ProtocolBuffers/Header.hs --- a/Text/ProtocolBuffers/Header.hs +++ b/Text/ProtocolBuffers/Header.hs @@ -1,12 +1,10 @@ --- | This provides much that is needed for the output of 'hprotoc' to --- compile. It will be imported qualified as P', the prime ensuring --- no name conflicts are possible. +-- | This provides what is needed for the output of 'hprotoc' to +-- compile. This and the Prelude will both be imported qualified as +-- P', the prime ensuring no name conflicts are possible. module Text.ProtocolBuffers.Header - ( -- needed for Gen.hs output - emptyBS - , pack - , append - , module Control.Monad + ( emptyBS, pack, append, fromMaybe, ap + , fromDistinctAscList, member + , throwError,catchError , module Data.Generics , module Data.Typeable , module Text.ProtocolBuffers.Basic @@ -18,29 +16,32 @@ ) where import Control.Monad(ap) +import Control.Monad.Error.Class(throwError,catchError) import Data.ByteString.Lazy(empty) import Data.ByteString.Lazy.Char8(pack) import Data.Generics(Data(..)) +import Data.Maybe(fromMaybe) import Data.Sequence((|>)) -- for append, see below +import Data.Set(fromDistinctAscList,member) import Data.Typeable(Typeable(..)) import Text.ProtocolBuffers.Basic -- all import Text.ProtocolBuffers.Default() import Text.ProtocolBuffers.Extensions - ( wireSizeExtField,wirePutExtField,loadExtension,getMessageExt,getBareMessageExt + ( wireSizeExtField,wirePutExtField,loadExtension,notExtension , GPB,Key(..),ExtField,ExtendMessage(..),MessageAPI(..),ExtKey(wireGetKey) ) import Text.ProtocolBuffers.Identifiers(FIName(..),MName(..),FName(..)) import Text.ProtocolBuffers.Mergeable() import Text.ProtocolBuffers.Reflections - ( ReflectDescriptor(..),ReflectEnum(..),EnumInfo(..),ProtoName(..),DescriptorInfo(extRanges),makePNF ) + ( ReflectDescriptor(..),ReflectEnum(..),EnumInfo(..),ProtoName(..) + , GetMessageInfo(GetMessageInfo),DescriptorInfo(extRanges),makePNF ) import Text.ProtocolBuffers.Unknown ( UnknownField,UnknownMessage(..),wireSizeUnknownField,wirePutUnknownField,loadUnknown ) import Text.ProtocolBuffers.WireMessage ( prependMessageSize,putSize , wireSizeReq,wireSizeOpt,wireSizeRep , wirePutReq,wirePutOpt,wirePutRep - , getMessage,getBareMessage - , getMessageWith,getBareMessageWith + , getMessageWith,getBareMessageWith,wireGetEnum , wireSizeErr,wirePutErr,wireGetErr , unknown,unknownField) diff --git a/Text/ProtocolBuffers/WireMessage.hs b/Text/ProtocolBuffers/WireMessage.hs --- a/Text/ProtocolBuffers/WireMessage.hs +++ b/Text/ProtocolBuffers/WireMessage.hs @@ -29,22 +29,24 @@ , wireSizeReq,wireSizeOpt,wireSizeRep , wirePutReq,wirePutOpt,wirePutRep , wireSizeErr,wirePutErr,wireGetErr - , getMessage,getBareMessage,getMessageWith,getBareMessageWith + , getMessageWith,getBareMessageWith,wireGetEnum , unknownField,unknown,wireGetFromWire , castWord64ToDouble,castWord32ToFloat,castDoubleToWord64,castFloatToWord32 , zzEncode64,zzEncode32,zzDecode64,zzDecode32 ) where --- GHC internals for getting at Double and Float representation as Word64 and Word32 import Control.Monad(when) +import Control.Monad.Error.Class(throwError,catchError) import Control.Monad.ST import Data.Array.ST import Data.Bits (Bits(..)) import qualified Data.ByteString.Lazy as BS (length) import qualified Data.Foldable as F(foldl',forM_) import Data.List (genericLength) -import qualified Data.Set as Set(notMember,delete,null) +import qualified Data.Set as Set(delete,null,notMember) import Data.Typeable (Typeable(..)) +-- GHC internals for getting at Double and Float representation as Word64 and Word32 +-- This has been superceded by the ST array trick (ugly, but promised to work) --import GHC.Exts (Double(D#),Float(F#),unsafeCoerce#) --import GHC.Word (Word64(W64#)) -- ,Word32(W32#)) @@ -59,8 +61,6 @@ import Text.ProtocolBuffers.Reflections(ReflectDescriptor(reflectDescriptorInfo,getMessageInfo) ,DescriptorInfo(..),GetMessageInfo(..)) ---import Debug.Trace(trace) - -- External user API for writing and reading messages -- | This computes the size of the message's fields with tags on the @@ -155,7 +155,7 @@ messageAsFieldGetM = do wireTag <- fmap WireTag getVarInt let (fieldId,wireType) = splitWireTag wireTag - when (wireType /= 2) (fail $ "messageAsFieldGetM: wireType was not 2 "++show (fieldId,wireType)) + when (wireType /= 2) (throwError $ "messageAsFieldGetM: wireType was not 2 "++show (fieldId,wireType)) msg <- wireGet 11 return (fieldId,msg) @@ -237,19 +237,14 @@ splitWireTag (WireTag wireTag) = ( FieldId . fromIntegral $ wireTag `shiftR` 3 , WireType . fromIntegral $ wireTag .&. 7 ) --- | Used by generated code -getMessage :: (Mergeable message, ReflectDescriptor message,Typeable message) - => (FieldId -> message -> Get message) -- handles "allowed" wireTags - -> Get message -getMessage = getMessageWith unknown --- getMessage assumes the wireTag for the message, if it existed, has already been read. --- getMessage assumes that it still needs to read the Varint encoded length of the message. + +-- getMessageWith assumes the wireTag for the message, if it existed, has already been read. +-- getMessageWith assumes that it still needs to read the Varint encoded length of the message. getMessageWith :: (Mergeable message, ReflectDescriptor message) - => (FieldId -> WireType -> message -> Get message) -- handle wireTags that updater cannot - -> (FieldId -> message -> Get message) -- handles "allowed" wireTags + => (WireTag -> FieldId -> WireType -> message -> Get message) -> Get message -getMessageWith punt updater = do +getMessageWith updater = do messageLength <- getVarInt start <- bytesRead let stop = messageLength+start @@ -263,10 +258,8 @@ GT -> do wireTag <- fmap WireTag getVarInt -- get tag off wire let (fieldId,wireType) = splitWireTag wireTag - if Set.notMember wireTag allowed - then punt fieldId wireType message >>= go reqs - else let reqs' = Set.delete wireTag reqs - in updater fieldId message >>= go reqs' + reqs' = Set.delete wireTag reqs + updater wireTag fieldId wireType message >>= go reqs' go' message = do here <- bytesRead case compare stop here of @@ -275,44 +268,29 @@ GT -> do wireTag <- fmap WireTag getVarInt -- get tag off wire let (fieldId,wireType) = splitWireTag wireTag - if Set.notMember wireTag allowed - then punt fieldId wireType message >>= go' - else updater fieldId message >>= go' + updater wireTag fieldId wireType message >>= go' go required initialMessage where initialMessage = mergeEmpty - (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage + (GetMessageInfo {requiredTags=required}) = getMessageInfo initialMessage notEnoughData messageLength start = - fail ("Text.ProtocolBuffers.WireMessage.getMessage: Required fields missing when processing " - ++ (show . descName . reflectDescriptorInfo $ initialMessage) - ++ " at (messageLength,start) == " ++ show (messageLength,start)) + throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: Required fields missing when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage) + ++ " at (messageLength,start) == " ++ show (messageLength,start)) tooMuchData messageLength start here = - fail ("Text.ProtocolBuffers.WireMessage.getMessage : overran expected length when processing" - ++ (show . descName . reflectDescriptorInfo $ initialMessage) - ++ " at (messageLength,start,here) == " ++ show (messageLength,start,here)) - -unknown :: (Typeable a,ReflectDescriptor a) => FieldId -> WireType -> a -> Get a -unknown fieldId wireType initialMessage = do - here <- bytesRead - fail ("Text.ProtocolBuffers.WireMessage.unkown: Unknown wire tag read (type,fieldId,wireType,here) == " - ++ show (typeOf initialMessage,fieldId,wireType,here) ++ " when processing " - ++ (show . descName . reflectDescriptorInfo $ initialMessage)) + throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: overran expected length when processing" + ++ (show . descName . reflectDescriptorInfo $ initialMessage) + ++ " at (messageLength,start,here) == " ++ show (messageLength,start,here)) -- | Used by generated code --- getBareMessage assumes the wireTag for the message, if it existed, has already been read. --- getBareMessage assumes that it does needs to read the Varint encoded length of the message. --- getBareMessage will consume the entire ByteString it is operating on, or until it --- finds any STOP_GROUP tag -getBareMessage :: (Typeable message, Mergeable message, ReflectDescriptor message) - => (FieldId -> message -> Get message) -- handles "allowed" wireTags - -> Get message -getBareMessage = getBareMessageWith unknown - +-- getBareMessageWith assumes the wireTag for the message, if it existed, has already been read. +-- getBareMessageWith assumes that it does needs to read the Varint encoded length of the message. +-- getBareMessageWith will consume the entire ByteString it is operating on, or until it +-- finds any STOP_GROUP tag (wireType == 4) getBareMessageWith :: (Mergeable message, ReflectDescriptor message) - => (FieldId -> WireType -> message -> Get message) -- handle wireTags that updater cannot - -> (FieldId -> message -> Get message) -- handles "allowed" wireTags + => (WireTag -> FieldId -> WireType -> message -> Get message) -- handle wireTags that are unknown or produce errors -> Get message -getBareMessageWith punt updater = go required initialMessage +getBareMessageWith updater = go required initialMessage where go reqs message | Set.null reqs = go' message | otherwise = do @@ -322,32 +300,37 @@ wireTag <- fmap WireTag getVarInt -- get tag off wire let (fieldId,wireType) = splitWireTag wireTag if wireType == 4 then notEnoughData -- END_GROUP too soon - else if Set.notMember wireTag allowed - then punt fieldId wireType message >>= go reqs - else let reqs' = Set.delete wireTag reqs - in updater fieldId message >>= go reqs' + else let reqs' = Set.delete wireTag reqs + in updater wireTag fieldId wireType message >>= go reqs' go' message = do done <- isReallyEmpty if done then return message else do wireTag <- fmap WireTag getVarInt -- get tag off wire - let (fieldId,wireType) = splitWireTag wireTag -- WIRETYPE_END_GROUP + let (fieldId,wireType) = splitWireTag wireTag if wireType == 4 then return message - else if Set.notMember wireTag allowed - then punt fieldId wireType message >>= go' - else updater fieldId message >>= go' + else updater wireTag fieldId wireType message >>= go' initialMessage = mergeEmpty - (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage - notEnoughData = fail ("Text.ProtocolBuffers.WireMessage.getBareMessage: Required fields missing when processing " - ++ (show . descName . reflectDescriptorInfo $ initialMessage)) + (GetMessageInfo {requiredTags=required}) = getMessageInfo initialMessage + notEnoughData = throwError ("Text.ProtocolBuffers.WireMessage.getBareMessageWith: Required fields missing when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage)) -unknownField :: FieldId -> Get a -unknownField fieldId = do +unknownField :: Typeable a => a -> FieldId -> Get a +unknownField msg fieldId = do here <- bytesRead - fail ("Impossible? Text.ProtocolBuffers.WireMessage.unknownField " - ++" The Message's updater claims there is an unknown field id on wire: "++show fieldId - ++" at a position just before here == "++show here) + throwError ("Impossible? Text.ProtocolBuffers.WireMessage.unknownField" + ++"\n Updater for "++show (typeOf msg)++" claims there is an unknown field id on wire: "++show fieldId + ++"\n at a position just before byte location "++show here) + +unknown :: (Typeable a,ReflectDescriptor a) => FieldId -> WireType -> a -> Get a +unknown fieldId wireType initialMessage = do + here <- bytesRead + throwError ("Text.ProtocolBuffers.WireMessage.unknown: Unknown field found or failure parsing field (e.g. unexpected Enum value):" + ++ "(message type name,field id number,wire type code,bytes read) == " + ++ show (typeOf initialMessage,fieldId,wireType,here) ++ " when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage)) + {-# INLINE castWord32ToFloat #-} castWord32ToFloat :: Word32 -> Float --castWord32ToFloat (W32# w) = F# (unsafeCoerce# w) @@ -376,8 +359,8 @@ , " does not match internal type ", show (typeOf x) ] wireGetErr :: Typeable a => FieldType -> Get a wireGetErr ft = answer where - answer = fail $ concat [ "Impossible? wireGet field type mismatch error: Field type number ", show ft - , " does not match internal type ", show (typeOf (undefined `asTypeOf` typeHack answer)) ] + answer = throwError $ concat [ "Impossible? wireGet field type mismatch error: Field type number ", show ft + , " does not match internal type ", show (typeOf (undefined `asTypeOf` typeHack answer)) ] typeHack :: Get a -> a typeHack = undefined @@ -458,7 +441,7 @@ case x of 0 -> return False x' | x' < 128 -> return True - _ -> fail ("TYPE_BOOL read failure : " ++ show x) + _ -> throwError ("TYPE_BOOL read failure : " ++ show x) wireGet ft = wireGetErr ft instance Wire Utf8 where @@ -467,7 +450,7 @@ wireSize ft x = wireSizeErr ft x wirePut {- TYPE_STRING -} 9 x = putVarUInt (BS.length (utf8 x)) >> putLazyByteString (utf8 x) wirePut ft x = wirePutErr ft x - wireGet {- TYPE_STRING -} 9 = getVarInt >>= getLazyByteString >>= return . Utf8 + wireGet {- TYPE_STRING -} 9 = getVarInt >>= getLazyByteString >>= verifyUtf8 wireGet ft = wireGetErr ft instance Wire ByteString where @@ -476,7 +459,7 @@ wireSize ft x = wireSizeErr ft x wirePut {- TYPE_BYTES -} 12 x = putVarUInt (BS.length x) >> putLazyByteString x wirePut ft x = wirePutErr ft x - wireGet {- TYPE_BYTES -} 12 = getVarInt >>= getLazyByteString >>= return + wireGet {- TYPE_BYTES -} 12 = getVarInt >>= getLazyByteString wireGet ft = wireGetErr ft -- Wrap a protocol-buffer Enum in fromEnum or toEnum and serialize the Int: @@ -488,6 +471,23 @@ wireGet {- TYPE_ENUM -} 14 = getVarInt wireGet ft = wireGetErr ft +{-# INLINE verifyUtf8 #-} +verifyUtf8 :: ByteString -> Get Utf8 +verifyUtf8 bs = case isValidUTF8 bs of + Nothing -> return (Utf8 bs) + Just i -> throwError $ "Text.ProtocolBuffers.WireMessage.verifyUtf8: ByteString is not valid utf8 at position "++show i + +{-# INLINE wireGetEnum #-} +wireGetEnum :: (Typeable e, Enum e) => (Int -> Maybe e) -> Get e +wireGetEnum toMaybe'Enum = do + int <- wireGet 14 + case toMaybe'Enum int of + Just v -> return v + Nothing -> throwError (msg ++ show int) + where msg = "Bad wireGet of Enum "++show (typeOf (undefined `asTypeOf` typeHack toMaybe'Enum))++", unrecognized Int value is " + typeHack :: (Int -> Maybe e) -> e + typeHack f = maybe undefined id (f undefined) + -- This will have to examine the value of positive numbers to get the size {-# INLINE size'Varint #-} size'Varint :: (Bits a,Integral a) => a -> Int64 @@ -586,9 +586,9 @@ there <- bytesRead return ((there-here)+len) 3 -> lenOf (skipGroup fi) - 4 -> fail $ "Cannot wireGetFromWire with wireType of STOP_GROUP: "++show (fi,wt) + 4 -> throwError $ "Cannot wireGetFromWire with wireType of STOP_GROUP: "++show (fi,wt) 5 -> return 4 - wtf -> fail $ "Invalid wire type (expected 0,1,2,3,or 5) found: "++show (fi,wtf) + wtf -> throwError $ "Invalid wire type (expected 0,1,2,3,or 5) found: "++show (fi,wtf) lenOf g = do here <- bytesRead there <- lookAhead (g >> bytesRead) return (there-here) @@ -606,10 +606,10 @@ 1 -> skip 8 >> go 2 -> getVarInt >>= skip >> go 3 -> skipGroup fieldId >> go - 4 | start_fi /= fieldId -> fail $ "skipGroup failed, fieldId mismatch bewteen START_GROUP and STOP_GROUP: "++show (start_fi,(fieldId,wireType)) + 4 | start_fi /= fieldId -> throwError $ "skipGroup failed, fieldId mismatch bewteen START_GROUP and STOP_GROUP: "++show (start_fi,(fieldId,wireType)) | otherwise -> return () 5 -> skip 4 >> go - wtf -> fail $ "Invalid wire type (expected 0,1,2,3,4,or 5) found: "++show (fieldId,wtf) + wtf -> throwError $ "Invalid wire type (expected 0,1,2,3,4,or 5) found: "++show (fieldId,wtf) {- enum WireType { @@ -659,3 +659,216 @@ toWireType 17 = 0 toWireType 18 = 0 toWireType x = error $ "Text.ProcolBuffers.Basic.toWireType: Bad FieldType: "++show x + +{- + +-- getMessageWith assumes the wireTag for the message, if it existed, has already been read. +-- getMessageWith assumes that it still needs to read the Varint encoded length of the message. +getMessageWith :: (Mergeable message, ReflectDescriptor message) + => (FieldId -> WireType -> message -> Get message) -- handle wireTags that updater cannot + -> (FieldId -> message -> Get message) -- handles "allowed" wireTags + -> Get message +getMessageWith punt updater = do + messageLength <- getVarInt + start <- bytesRead + let stop = messageLength+start + -- switch from go to go' once all the required fields have been found + go reqs message | Set.null reqs = go' message + | otherwise = do + here <- bytesRead + case compare stop here of + EQ -> notEnoughData messageLength start + LT -> tooMuchData messageLength start here + GT -> do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (fieldId,wireType) = splitWireTag wireTag + if Set.notMember wireTag allowed + then punt fieldId wireType message >>= go reqs + else let reqs' = Set.delete wireTag reqs + in catchError (updater fieldId message) + (\_ -> punt fieldId wireType message) + >>= go reqs' + go' message = do + here <- bytesRead + case compare stop here of + EQ -> return message + LT -> tooMuchData messageLength start here + GT -> do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (fieldId,wireType) = splitWireTag wireTag + if Set.notMember wireTag allowed + then punt fieldId wireType message >>= go' + else catchError (updater fieldId message) + (\_ -> punt fieldId wireType message) + >>= go' + go required initialMessage + where + initialMessage = mergeEmpty + (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage + notEnoughData messageLength start = + fail ("Text.ProtocolBuffers.WireMessage.getMessageWith: Required fields missing when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage) + ++ " at (messageLength,start) == " ++ show (messageLength,start)) + tooMuchData messageLength start here = + fail ("Text.ProtocolBuffers.WireMessage.getMessageWith: overran expected length when processing" + ++ (show . descName . reflectDescriptorInfo $ initialMessage) + ++ " at (messageLength,start,here) == " ++ show (messageLength,start,here)) + +-- | Used by generated code +-- getBareMessageWith assumes the wireTag for the message, if it existed, has already been read. +-- getBareMessageWith assumes that it does needs to read the Varint encoded length of the message. +-- getBareMessageWith will consume the entire ByteString it is operating on, or until it +-- finds any STOP_GROUP tag +getBareMessageWith :: (Mergeable message, ReflectDescriptor message) + => (FieldId -> WireType -> message -> Get message) -- handle wireTags that updater cannot + -> (FieldId -> message -> Get message) -- handles "allowed" wireTags + -> Get message +getBareMessageWith punt updater = go required initialMessage + where + go reqs message | Set.null reqs = go' message + | otherwise = do + done <- isReallyEmpty + if done then notEnoughData + else do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (fieldId,wireType) = splitWireTag wireTag + if wireType == 4 then notEnoughData -- END_GROUP too soon + else if Set.notMember wireTag allowed + then punt fieldId wireType message >>= go reqs + else let reqs' = Set.delete wireTag reqs + in catchError (updater fieldId message) + (\_ -> punt fieldId wireType message) + >>= go reqs' + go' message = do + done <- isReallyEmpty + if done then return message + else do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (fieldId,wireType) = splitWireTag wireTag -- WIRETYPE_END_GROUP + if wireType == 4 then return message + else if Set.notMember wireTag allowed + then punt fieldId wireType message >>= go' + else catchError (updater fieldId message) + (\_ -> punt fieldId wireType message) + >>= go' + initialMessage = mergeEmpty + (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage + notEnoughData = fail ("Text.ProtocolBuffers.WireMessage.getBareMessageWith: Required fields missing when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage)) + + +-} +{- +-- getMessageWith assumes the wireTag for the message, if it existed, has already been read. +-- getMessageWith assumes that it still needs to read the Varint encoded length of the message. +getMessageWith :: (Mergeable message, ReflectDescriptor message) + => (FieldId -> message -> Get message) -- handles "allowed" wireTags including known extensions + -> Maybe (FieldId -> WireType -> message -> Get message) -- handle extension wireTags that updater does not + -> (FieldId -> WireType -> message -> Get message) -- handle wireTags that are unknown or produce errors + -> Get message +getMessageWith updater mayExt punt = do + messageLength <- getVarInt + start <- bytesRead + let stop = messageLength+start + getExt = case mayExt of + Nothing -> punt + Just loadExt -> + (\fieldId wireType msg -> catchError (loadExt fieldId wireType msg) + (\_ -> punt fieldId wireType msg)) + -- switch from go to go' once all the required fields have been found + go reqs message | Set.null reqs = go' message + | otherwise = do + here <- bytesRead + case compare stop here of + EQ -> notEnoughData messageLength start + LT -> tooMuchData messageLength start here + GT -> do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (fieldId,wireType) = splitWireTag wireTag + if Set.notMember wireTag allowed + then getExt fieldId wireType message >>= go reqs + else let reqs' = Set.delete wireTag reqs + in catchError (updater fieldId message) + (\_ -> punt fieldId wireType message) + >>= go reqs' + go' message = do + here <- bytesRead + case compare stop here of + EQ -> return message + LT -> tooMuchData messageLength start here + GT -> do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (fieldId,wireType) = splitWireTag wireTag + if Set.notMember wireTag allowed + then getExt fieldId wireType message >>= go' + else catchError (updater fieldId message) + (\_ -> punt fieldId wireType message) + >>= go' + go required initialMessage + where + initialMessage = mergeEmpty + (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage + notEnoughData messageLength start = + throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: Required fields missing when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage) + ++ " at (messageLength,start) == " ++ show (messageLength,start)) + tooMuchData messageLength start here = + throwError ("Text.ProtocolBuffers.WireMessage.getMessageWith: overran expected length when processing" + ++ (show . descName . reflectDescriptorInfo $ initialMessage) + ++ " at (messageLength,start,here) == " ++ show (messageLength,start,here)) + +-- | Used by generated code +-- getBareMessageWith assumes the wireTag for the message, if it existed, has already been read. +-- getBareMessageWith assumes that it does needs to read the Varint encoded length of the message. +-- getBareMessageWith will consume the entire ByteString it is operating on, or until it +-- finds any STOP_GROUP tag +getBareMessageWith :: (Mergeable message, ReflectDescriptor message) + => (FieldId -> message -> Get message) -- handles "allowed" wireTags including known extensions + -> Maybe (FieldId -> WireType -> message -> Get message) -- handle extension wireTags that updater does not + -> (FieldId -> WireType -> message -> Get message) -- handle wireTags that are unknown or produce errors + -> Get message +getBareMessageWith updater mayExt punt = go required initialMessage + where + getExt = case mayExt of + Nothing -> punt + Just loadExt -> + (\fieldId wireType msg -> catchError (loadExt fieldId wireType msg) + (\_ -> punt fieldId wireType msg)) + go reqs message | Set.null reqs = go' message + | otherwise = do + done <- isReallyEmpty + if done then notEnoughData + else do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (fieldId,wireType) = splitWireTag wireTag + if wireType == 4 then notEnoughData -- END_GROUP too soon + else if Set.notMember wireTag allowed + then getExt fieldId wireType message >>= go reqs + else let reqs' = Set.delete wireTag reqs + in catchError (updater fieldId message) + (\_ -> punt fieldId wireType message) + >>= go reqs' + go' message = do + done <- isReallyEmpty + if done then return message + else do + wireTag <- fmap WireTag getVarInt -- get tag off wire + let (fieldId,wireType) = splitWireTag wireTag -- WIRETYPE_END_GROUP + if wireType == 4 then return message + else if Set.notMember wireTag allowed + then getExt fieldId wireType message >>= go' + else catchError (updater fieldId message) + (\_ -> punt fieldId wireType message) + >>= go' + initialMessage = mergeEmpty + (GetMessageInfo {requiredTags=required,allowedTags=allowed}) = getMessageInfo initialMessage + notEnoughData = throwError ("Text.ProtocolBuffers.WireMessage.getBareMessageWith: Required fields missing when processing " + ++ (show . descName . reflectDescriptorInfo $ initialMessage)) + +unknownField :: FieldId -> Get a +unknownField fieldId = do + here <- bytesRead + throwError ("Impossible? Text.ProtocolBuffers.WireMessage.unknownField" + ++"\n Updater claims there is an unknown field id on wire: "++show fieldId + ++"\n at a position just before byte location "++show here) +-} diff --git a/protocol-buffers.cabal b/protocol-buffers.cabal --- a/protocol-buffers.cabal +++ b/protocol-buffers.cabal @@ -1,5 +1,5 @@ name: protocol-buffers -version: 1.0.1 +version: 1.2.1 cabal-version: >= 1.2 build-type: Simple license: BSD3