proto-lens 0.1.0.4 → 0.1.0.5
raw patch · 6 files changed
+140/−117 lines, 6 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Data.ProtoLens.Message: def :: a
+ Data.ProtoLens.Message: def :: Default a => a
Files
- proto-lens.cabal +1/−1
- src/Data/ProtoLens/Encoding.hs +114/−83
- src/Data/ProtoLens/Encoding/Bytes.hs +4/−4
- src/Data/ProtoLens/Encoding/Wire.hs +15/−24
- src/Data/ProtoLens/Message.hs +3/−1
- src/Data/ProtoLens/TextFormat.hs +3/−4
proto-lens.cabal view
@@ -1,5 +1,5 @@ name: proto-lens-version: 0.1.0.4+version: 0.1.0.5 synopsis: A lens-based implementation of protocol buffers in Haskell. description: The proto-lens library provides to protocol buffers using modern
src/Data/ProtoLens/Encoding.hs view
@@ -8,7 +8,9 @@ -- -- TODO: Currently all operations are on strict ByteStrings; -- we should try to generalize to lazy Bytestrings as well.+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.ProtoLens.Encoding(@@ -23,7 +25,7 @@ import Data.ProtoLens.Encoding.Wire import Control.Applicative ((<|>), (<$>))-import Control.Monad (foldM)+import Control.Monad (foldM, guard, join) import Data.Attoparsec.ByteString as Parse import Data.Bool (bool) import Data.Text.Encoding (encodeUtf8, decodeUtf8')@@ -35,6 +37,7 @@ import Data.Monoid (mconcat, mempty) import Data.Foldable (foldMap, toList, foldl') import Lens.Family2 (set, over, (^.), (&))+import Data.Functor.Identity (Identity(..)) -- TODO: We could be more incremental when parsing/encoding length-based fields, -- rather than forcing the whole thing. E.g., for encoding we're doing extra@@ -43,10 +46,32 @@ -- | Decode a message from its wire format. Returns 'Left' if the decoding -- fails. decodeMessage :: Message msg => B.ByteString -> Either String msg-decodeMessage input =- parseOnly (Parse.manyTill getTaggedValue endOfInput) input- >>= taggedValuesToMessage+decodeMessage input = parseOnly (parseMessage endOfInput) input +-- | Parse a message with the given ending delimiter (which will be EndGroup in+-- the case of a group, and end-of-input otherwise).+parseMessage :: forall msg . Message msg => Parser () -> Parser msg+parseMessage end = do+ (msg, unsetFields) <- loop def requiredFields+ if Map.null unsetFields+ then return $ reverseRepeatedFields fields msg+ else fail $ "Missing required fields "+ ++ show (map fieldDescriptorName+ $ Map.elems $ unsetFields)+ where+ fields = fieldsByTag descriptor+ requiredFields = Map.filter isRequired fields+ loop :: msg -> Map.Map Tag (FieldDescriptor msg)+ -> Parser (msg, Map.Map Tag (FieldDescriptor msg))+ loop msg unsetFields = ((msg, unsetFields) <$ end)+ <|> do+ tv@(TaggedValue tag _) <- getTaggedValue+ case Map.lookup (Tag tag) fields of+ Nothing -> loop msg unsetFields+ Just field -> do+ !msg' <- parseAndAddField msg field tv+ loop msg' $! Map.delete (Tag tag) unsetFields+ -- | Decode a message from its wire format. Throws an error if the decoding -- fails. decodeMessageOrDie :: Message msg => B.ByteString -> msg@@ -54,69 +79,61 @@ Left e -> error $ "decodeMessageOrDie: " ++ e Right x -> x --- | Convert a sequence of parsed key-value pairs into a Message via its--- descriptor. Will fail if any of the key-value pairs do not match those--- expected by the field descriptors.-taggedValuesToMessage :: Message msg => [TaggedValue] -> Either String msg-taggedValuesToMessage tvs- | missing <- missingFields fields tvs, not $ null missing- = Left $ "Missing required fields " ++ show missing- | otherwise = reverseRepeatedFields fields <$> result- where- addTaggedValue msg tv@(TaggedValue tag _) =- case Map.lookup (Tag tag) fields of- Nothing -> return msg- Just field -> parseAndAddField msg field tv- fields = fieldsByTag descriptor- result = foldM addTaggedValue def tvs--missingFields :: Map.Map Tag (FieldDescriptor msg) -> [TaggedValue] -> [String]-missingFields fields- = map fieldDescriptorName- . Map.elems- . foldl' (\m (TaggedValue t _) -> Map.delete (Tag t) m) requiredFields- where- requiredFields = Map.filter isRequired fields- runEither :: Either String a -> Parser a-runEither (Left x) = fail x-runEither (Right x) = return x+runEither = either fail return parseAndAddField :: msg -> FieldDescriptor msg -> TaggedValue- -> Either String msg+ -> Parser msg parseAndAddField- msg+ !msg (FieldDescriptor name typeDescriptor accessor)- (TaggedValue tag (WireValue wt val))- = case fieldWireType typeDescriptor of- FieldWireType fieldWt _ get -> let- getSimpleVal = do- Equal <- equalWireTypes name fieldWt wt- get val+ (TaggedValue tag (WireValue wt val)) = let+ getSimpleVal = case fieldWireType typeDescriptor of+ GroupFieldType -> do+ Equal <- equalWireTypes name StartGroup wt+ parseMessage (endOfGroup name tag)+ FieldWireType fieldWt _ get -> do+ Equal <- equalWireTypes name fieldWt wt+ runEither $ get val -- Get a block of packed values, reversed.- getPackedVals = do+ getPackedVals = case fieldWireType typeDescriptor of+ GroupFieldType -> fail "Groups can't be packed"+ FieldWireType fieldWt _ get -> do Equal <- equalWireTypes name Lengthy wt- let getElt = getWireValue fieldWt tag >>= runEither . get- parseOnly (manyReversedTill getElt endOfInput) val+ let getElt = do+ wv <- getWireValue fieldWt tag+ x <- runEither $ get wv+ return $! x+ runEither $ parseOnly (manyReversedTill getElt endOfInput) val in case accessor of PlainField _ f -> do- x <- getSimpleVal- return $ set f x msg+ !x <- getSimpleVal+ return $! set f x msg OptionalField f -> do- x <- getSimpleVal- return $ set f (Just x) msg- RepeatedField Unpacked f -> do- x <- getSimpleVal- return $ over f (x:) msg- RepeatedField Packed f -> do- xs <- getPackedVals- return $ over f (xs++) msg+ !x <- getSimpleVal+ return $! set f (Just x) msg+ -- Parse either a packed or unpacked representation,+ -- depending on how it was encoded.+ -- Note that if fieldWt is Lengthy (e.g., "string" or+ -- message) we should always parse it as unpacked.+ RepeatedField _ f+ -> (do+ !x <- getSimpleVal+ return $! over f (\(!xs) -> x:xs) msg)+ <|> (do + xs <- getPackedVals+ return $! over f (\(!ys) -> xs++ys) msg)+ <|> fail ("Field " ++ name+ ++ "expects a repeated field wire type but found "+ ++ show wt) MapField keyLens valueLens f -> do entry <- getSimpleVal- return $ over f- (Map.insert (entry ^. keyLens) (entry ^. valueLens))+ let !key = entry ^. keyLens+ let !value = entry ^. valueLens+ return $! over f+ (Map.insert key value) msg -- | Run the parser zero or more times, until the "end" parser succeeds.@@ -126,7 +143,7 @@ where loop xs = (end >> return xs) <|> (p >>= \x -> loop (x:xs)) --- | Encode a message to the wire format.+-- | Encode a message to the wire format as a strict 'ByteString'. encodeMessage :: Message msg => msg -> B.ByteString encodeMessage = L.toStrict . toLazyByteString . buildMessage @@ -137,42 +154,50 @@ -- | Encode a message as a sequence of key-value pairs. messageToTaggedValues :: Message msg => msg -> [TaggedValue] messageToTaggedValues msg = mconcat- [ map (TaggedValue t) (messageFieldToVals fieldDescr msg)+ [ messageFieldToVals t fieldDescr msg | (Tag t, fieldDescr) <- Map.toList (fieldsByTag descriptor) ] -messageFieldToVals :: FieldDescriptor msg -> msg -> [WireValue]-messageFieldToVals (FieldDescriptor _ typeDescriptor accessor) msg =- case fieldWireType typeDescriptor of- FieldWireType wt convert _ -> case accessor of+messageFieldToVals :: Int -> FieldDescriptor a -> a -> [TaggedValue]+messageFieldToVals tag (FieldDescriptor _ typeDescriptor accessor) msg =+ let+ embed src+ = case fieldWireType typeDescriptor of+ FieldWireType wt convert _+ -> [TaggedValue tag $ WireValue wt (convert src)]+ GroupFieldType+ -> TaggedValue tag (WireValue StartGroup ())+ : messageToTaggedValues src+ ++ [TaggedValue tag $ WireValue EndGroup ()]+ embedPacked [] = []+ embedPacked src+ = case fieldWireType typeDescriptor of+ GroupFieldType -> error "GroupFieldType can't be packed"+ FieldWireType wt convert _ -> let+ v = L.toStrict $ toLazyByteString+ $ mconcat [putWireValue wt (convert x) | x <- src]+ in [TaggedValue tag $ WireValue Lengthy v]+ in case accessor of PlainField d f+ -- proto3 optional scalar field: | Optional <- d, src == fieldDefault -> []- | otherwise -> [WireValue wt (convert src)]+ -- proto3 optional non-scalar field, or proto2 required field:+ | otherwise -> embed src where src = msg ^. f- OptionalField f -> case msg ^. f of- Just src -> [WireValue wt (convert src)]- _ -> mempty- RepeatedField Unpacked f- -> [ WireValue wt (convert src)- | src <- toList (msg ^. f)- ]- RepeatedField Packed f- -> [WireValue Lengthy v]- where v = L.toStrict $ toLazyByteString- $ mconcat- [ putWireValue wt (convert src)- | src <- toList (msg ^. f)- ]+ -- proto2 optional field:+ OptionalField f -> foldMap embed (msg ^. f)+ -- Note: using 'concatMap' instead of 'foldMap' below+ -- seems to allow better list fusion.+ RepeatedField Unpacked f -> concatMap embed (msg ^. f)+ RepeatedField Packed f -> embedPacked (msg ^. f) MapField keyLens valueLens f ->- [ WireValue wt v- | (key, value) <- Map.toList (msg ^. f)- , let entry = def & set keyLens key & set valueLens value- , let v = convert entry- ]+ concatMap (\(k, v) -> embed $ def & set keyLens k & set valueLens v)+ $ Map.toList (msg ^. f) data FieldWireType value where FieldWireType :: WireType w -> (value -> w) -> (w -> Either String value) -> FieldWireType value+ GroupFieldType :: Message value => FieldWireType value fieldWireType :: FieldTypeDescriptor value -> FieldWireType value -- TODO: Don't let toEnum crash on unknown enum values.@@ -199,11 +224,17 @@ fieldWireType DoubleField = simpleFieldWireType Fixed64 doubleToWord wordToDouble fieldWireType StringField = FieldWireType Lengthy encodeUtf8- (stringizeError . decodeUtf8')+ (stringizeError . decodeUtf8') fieldWireType BytesField = identityFieldWireType Lengthy-fieldWireType MessageField = FieldWireType Lengthy encodeMessage decodeMessage-fieldWireType GroupField =- FieldWireType StartGroup messageToTaggedValues taggedValuesToMessage+fieldWireType MessageField = FieldWireType Lengthy encodeMessage+ decodeMessage+fieldWireType GroupField = GroupFieldType++endOfGroup :: String -> Int -> Parser ()+endOfGroup name tag = do+ TaggedValue tag' (WireValue wt _) <- getTaggedValue+ Equal <- equalWireTypes name EndGroup wt+ guard (tag == tag') -- | Helper function to define a field type whose decoding operation can't fail. simpleFieldWireType :: WireType w -> (value -> w) -> (w -> value)
src/Data/ProtoLens/Encoding/Bytes.hs view
@@ -4,6 +4,7 @@ -- license that can be found in the LICENSE file or at -- https://developers.google.com/open-source/licenses/bsd +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -38,12 +39,11 @@ getVarInt :: Parser Word64 getVarInt = loop 1 0 where- -- TODO: bang pattern?- loop s n = do+ loop !s !n = do b <- anyWord8 let n' = n + s * fromIntegral (b .&. 127) if (b .&. 128) == 0- then return n'+ then return $! n' else loop (128*s) n' -- | Little-endian decoding function.@@ -51,7 +51,7 @@ anyBits = loop 0 0 where size = finiteBitSize (undefined :: a)- loop w n+ loop !w !n | n >= size = return w | otherwise = do b <- anyWord8
src/Data/ProtoLens/Encoding/Wire.hs view
@@ -38,8 +38,8 @@ Fixed64 :: WireType Word64 Fixed32 :: WireType Word32 Lengthy :: WireType B.ByteString- StartGroup :: WireType [TaggedValue]- EndGroup :: WireType Void+ StartGroup :: WireType ()+ EndGroup :: WireType () -- A value read from the wire data WireValue = forall a . WireValue !(WireType a) !a@@ -54,16 +54,17 @@ -- Assert that two wire types are the same, or fail with a message about this -- field.-equalWireTypes :: String -> WireType a -> WireType b- -> Either String (Equal a b)-equalWireTypes _ VarInt VarInt = Right Equal-equalWireTypes _ Fixed64 Fixed64 = Right Equal-equalWireTypes _ Fixed32 Fixed32 = Right Equal-equalWireTypes _ Lengthy Lengthy = Right Equal-equalWireTypes _ StartGroup StartGroup = Right Equal-equalWireTypes _ EndGroup EndGroup = Right Equal+{-# INLINE equalWireTypes #-}+equalWireTypes :: Monad m => String -> WireType a -> WireType b+ -> m (Equal a b)+equalWireTypes _ VarInt VarInt = return Equal+equalWireTypes _ Fixed64 Fixed64 = return Equal+equalWireTypes _ Fixed32 Fixed32 = return Equal+equalWireTypes _ Lengthy Lengthy = return Equal+equalWireTypes _ StartGroup StartGroup = return Equal+equalWireTypes _ EndGroup EndGroup = return Equal equalWireTypes name expected actual- = Left $ "Field " ++ name ++ " expects wire type " ++ show expected+ = fail $ "Field " ++ name ++ " expects wire type " ++ show expected ++ " but found " ++ show actual getWireValue :: WireType a -> Int -> Parser a@@ -71,21 +72,15 @@ getWireValue Fixed64 _ = anyBits getWireValue Fixed32 _ = anyBits getWireValue Lengthy _ = getVarInt >>= Parse.take . fromIntegral--- Precompute the final EndGroup tag and keep parsing key-value pairs until--- we reach the EndGroup.-getWireValue StartGroup tag = Parse.manyTill getTaggedValue end- where- typeAndTag = BL.toStrict $ toLazyByteString (putTypeAndTag EndGroup tag)- end = Parse.string typeAndTag-getWireValue EndGroup tag =- fail $ "Encountered unexpected end of group with tag " ++ show tag+getWireValue StartGroup tag = return ()+getWireValue EndGroup tag = return () putWireValue :: WireType a -> a -> Builder putWireValue VarInt n = putVarInt n putWireValue Fixed64 n = word64LE n putWireValue Fixed32 n = word32LE n putWireValue Lengthy b = putVarInt (fromIntegral $ B.length b) <> byteString b-putWireValue StartGroup tvs = foldMap putTaggedValue tvs+putWireValue StartGroup _ = mempty putWireValue EndGroup _ = mempty data SomeWireType where@@ -126,9 +121,5 @@ return $ TaggedValue tag (WireValue wt val) putTaggedValue :: TaggedValue -> Builder-putTaggedValue (TaggedValue tag (WireValue StartGroup val)) =- putTypeAndTag StartGroup tag- <> putWireValue StartGroup val- <> putTypeAndTag EndGroup tag putTaggedValue (TaggedValue tag (WireValue wt val)) = putTypeAndTag wt tag <> putWireValue wt val
src/Data/ProtoLens/Message.hs view
@@ -64,7 +64,9 @@ -- | A description of a specific field of a protocol buffer. ----- The 'String' parameter is the original name of the field in the .proto file.+-- The 'String' parameter is the name of the field from the .proto file,+-- as used in TextFormat, with the same behavior for groups as+-- 'fieldsByTextFormatName'. -- (Haddock doesn't support per-argument docs for GADTs.) data FieldDescriptor msg where FieldDescriptor :: String
src/Data/ProtoLens/TextFormat.hs view
@@ -70,11 +70,10 @@ -- for each field. We use a single "sep" for all fields (and all elements -- of all the repeated fields) to avoid putting some repeated fields on one -- line and other fields on multiple lines, which is less readable.- = sep $ concatMap (pprintField msg) $ Map.toList- $ fieldsByTextFormatName descr+ = sep $ concatMap (pprintField msg) $ Map.elems $ fieldsByTag descr -pprintField :: msg -> (String, FieldDescriptor msg) -> [Doc]-pprintField msg (name, FieldDescriptor _ typeDescr accessor)+pprintField :: msg -> FieldDescriptor msg -> [Doc]+pprintField msg (FieldDescriptor name typeDescr accessor) = map (pprintFieldValue name typeDescr) $ case accessor of PlainField d f | Optional <- d, val == fieldDefault -> []