{-
  Copyright 2016 Awake Networks

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

-- | Low level functions for reading data in the protobufs wire format.
--
-- This module exports a function 'decodeWire' which parses data in the raw wire
-- format into an untyped 'Map' representation.
--
-- This module also provides 'Parser' types and functions for reading messages
-- from the untyped 'Map' representation obtained from 'decodeWire'.

{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PatternGuards              #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}

module Proto3.Wire.Decode
    ( -- * Untyped Representation
      ParsedField(..)
    , decodeWire
      -- * Parser Types
    , Parser(..)
    , RawPrimitive
    , RawField
    , RawMessage
    , ParseError(..)
    , foldFields
    , parse
      -- * Primitives
    , bool
    , int32
    , int64
    , uint32
    , uint64
    , sint32
    , sint64
    , enum
    , byteString
    , lazyByteString
    , shortByteString
    , text
    , shortText
    , packedVarints
    , packedFixed32
    , packedFixed64
    , packedFloats
    , packedDoubles
    , fixed32
    , fixed64
    , sfixed32
    , sfixed64
    , float
    , double
      -- * Decoding Messages
    , at
    , oneof
    , one
    , repeated
    , embedded
    , embedded'
      -- * ZigZag codec
    , zigZagDecode
    ) where

import           Control.Applicative
import           Control.Arrow (first)
import           Control.Exception       ( Exception )
import           Control.Monad           ( msum, foldM )
import           Data.Bits
import qualified Data.ByteString         as B
import qualified Data.ByteString.Lazy    as BL
import qualified Data.ByteString.Short   as BS
import           Data.Foldable           ( foldl' )
import qualified Data.IntMap.Strict      as M -- TODO intmap
import           Data.Maybe              ( fromMaybe )
import           Data.Serialize.Get      ( Get, getWord8, getInt32le
                                         , getInt64le, getWord32le, getWord64le
                                         , runGet )
import           Data.Serialize.IEEE754  ( getFloat32le, getFloat64le )
import           Data.Text.Lazy          ( Text, pack )
import           Data.Text.Lazy.Encoding ( decodeUtf8' )
import qualified Data.Text.Short         as Text.Short
import qualified Data.Traversable        as T
import           Data.Int                ( Int32, Int64 )
import           Data.Word               ( Word8, Word32, Word64 )
import           Proto3.Wire.Class
import           Proto3.Wire.Types

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> :module Proto3.Wire.Decode Proto3.Wire.Types

-- | Decode a zigzag-encoded numeric type.
-- See: http://stackoverflow.com/questions/2210923/zig-zag-decoding
zigZagDecode :: (Num a, Bits a) => a -> a
zigZagDecode :: forall a. (Num a, Bits a) => a -> a
zigZagDecode a
i = forall a. Bits a => a -> Int -> a
shiftR a
i Int
1 forall a. Bits a => a -> a -> a
`xor` (-(a
i forall a. Bits a => a -> a -> a
.&. a
1))

-- | One field in a protobuf message.
--
-- We don't know what's inside some of these fields until we know what type
-- we're deserializing to, so we leave them as 'ByteString' until a later step
-- in the process.
data ParsedField = VarintField Word64
                 | Fixed32Field B.ByteString
                 | Fixed64Field B.ByteString
                 | LengthDelimitedField B.ByteString
    deriving (Int -> ParsedField -> ShowS
[ParsedField] -> ShowS
ParsedField -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ParsedField] -> ShowS
$cshowList :: [ParsedField] -> ShowS
show :: ParsedField -> [Char]
$cshow :: ParsedField -> [Char]
showsPrec :: Int -> ParsedField -> ShowS
$cshowsPrec :: Int -> ParsedField -> ShowS
Show, ParsedField -> ParsedField -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParsedField -> ParsedField -> Bool
$c/= :: ParsedField -> ParsedField -> Bool
== :: ParsedField -> ParsedField -> Bool
$c== :: ParsedField -> ParsedField -> Bool
Eq)

-- | Convert key-value pairs to a map of keys to a sequence of values with that
-- key, in their reverse occurrence order.
--
--
decodeWireMessage :: B.ByteString -> Either String RawMessage
decodeWireMessage :: ByteString -> Either [Char] RawMessage
decodeWireMessage = forall b r.
(b -> FieldNumber -> ParsedField -> b)
-> b -> (b -> r) -> ByteString -> Either [Char] r
decodeWire0 forall v.
Maybe (IntMap [v], Int, [v])
-> FieldNumber -> v -> Maybe (IntMap [v], Int, [v])
combineSeen' forall a. Maybe a
Nothing forall {a}. Maybe (IntMap [a], Int, [a]) -> IntMap [a]
close
  where
    close :: Maybe (IntMap [a], Int, [a]) -> IntMap [a]
close Maybe (IntMap [a], Int, [a])
Nothing = forall a. IntMap a
M.empty
    close (Just (IntMap [a]
m, Int
k, [a]
v)) = forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
M.insertWith forall a. [a] -> [a] -> [a]
(++) Int
k [a]
v IntMap [a]
m

    combineSeen' :: Maybe (M.IntMap [v], Int, [v]) -> FieldNumber -> v -> Maybe (M.IntMap [v], Int, [v])
    combineSeen' :: forall v.
Maybe (IntMap [v], Int, [v])
-> FieldNumber -> v -> Maybe (IntMap [v], Int, [v])
combineSeen' Maybe (IntMap [v], Int, [v])
b (FieldNumber Word64
fn) v
v = forall v.
Maybe (IntMap [v], Int, [v])
-> Int -> v -> Maybe (IntMap [v], Int, [v])
combineSeen Maybe (IntMap [v], Int, [v])
b (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
fn) v
v

    combineSeen :: Maybe (M.IntMap [v], Int, [v]) -> Int -> v -> Maybe (M.IntMap [v], Int, [v])
    combineSeen :: forall v.
Maybe (IntMap [v], Int, [v])
-> Int -> v -> Maybe (IntMap [v], Int, [v])
combineSeen Maybe (IntMap [v], Int, [v])
Nothing Int
k1 v
a1 = forall a. a -> Maybe a
Just (forall a. IntMap a
M.empty, Int
k1, [v
a1])
    combineSeen (Just (IntMap [v]
m, Int
k2, [v]
as)) Int
k1 v
a1 =
      if Int
k1 forall a. Eq a => a -> a -> Bool
== Int
k2
        then forall a. a -> Maybe a
Just (IntMap [v]
m, Int
k1, v
a1 forall a. a -> [a] -> [a]
: [v]
as)
        -- It might seem that we want to use DList but we don't because:
        -- - alter has worse performance than insertWith, and there's no upsert
        -- - We're building up a list of elements in a recursive way
        --    that will be opaque to GHC
        -- - DList would add another dependency
        else let !m' :: IntMap [v]
m' = forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
M.insertWith forall a. [a] -> [a] -> [a]
(++) Int
k2 [v]
as IntMap [v]
m
             in forall a. a -> Maybe a
Just (IntMap [v]
m', Int
k1, [v
a1])

decodeWire :: B.ByteString -> Either String [(FieldNumber, ParsedField)]
decodeWire :: ByteString -> Either [Char] [(FieldNumber, ParsedField)]
decodeWire = forall b r.
(b -> FieldNumber -> ParsedField -> b)
-> b -> (b -> r) -> ByteString -> Either [Char] r
decodeWire0 (\[(FieldNumber, ParsedField)]
xs FieldNumber
k ParsedField
v -> (FieldNumber
k,ParsedField
v)forall a. a -> [a] -> [a]
:[(FieldNumber, ParsedField)]
xs) [] forall a. [a] -> [a]
reverse

-- | Parses data in the raw wire format into an untyped 'Map' representation.
decodeWire0 :: (b -> FieldNumber -> ParsedField -> b) -> b -> (b -> r) -> B.ByteString -> Either String r
decodeWire0 :: forall b r.
(b -> FieldNumber -> ParsedField -> b)
-> b -> (b -> r) -> ByteString -> Either [Char] r
decodeWire0 b -> FieldNumber -> ParsedField -> b
cl b
z b -> r
finish ByteString
bstr = ByteString -> b -> Either [Char] r
drloop ByteString
bstr b
z
 where
   drloop :: ByteString -> b -> Either [Char] r
drloop !ByteString
bs b
xs | ByteString -> Bool
B.null ByteString
bs = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ b -> r
finish b
xs
   drloop !ByteString
bs b
xs | Bool
otherwise = do
      (Word64
w, ByteString
rest) <- ByteString -> Either [Char] (Word64, ByteString)
takeVarInt ByteString
bs
      WireType
wt <- Word8 -> Either [Char] WireType
gwireType forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w forall a. Bits a => a -> a -> a
.&. Word64
7)
      let fn :: Word64
fn = Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
3
      (ParsedField
res, ByteString
rest2) <- WireType -> ByteString -> Either [Char] (ParsedField, ByteString)
takeWT WireType
wt ByteString
rest
      ByteString -> b -> Either [Char] r
drloop ByteString
rest2 (b -> FieldNumber -> ParsedField -> b
cl b
xs (Word64 -> FieldNumber
FieldNumber Word64
fn) ParsedField
res)
{-# INLINE decodeWire0 #-}

eitherUncons :: B.ByteString -> Either String (Word8, B.ByteString)
eitherUncons :: ByteString -> Either [Char] (Word8, ByteString)
eitherUncons = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left [Char]
"failed to parse varint128") forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Word8, ByteString)
B.uncons

takeVarInt :: B.ByteString -> Either String (Word64, B.ByteString)
takeVarInt :: ByteString -> Either [Char] (Word64, ByteString)
takeVarInt !ByteString
bs =
  case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs of
     Maybe (Word8, ByteString)
Nothing -> forall a b. b -> Either a b
Right (Word64
0, ByteString
B.empty)
     Just (Word8
w1, ByteString
r1) -> do
       if Word8
w1 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1, ByteString
r1) else do
        let val1 :: Word64
val1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w1 forall a. Num a => a -> a -> a
- Word8
0x80)

        (Word8
w2,ByteString
r2) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r1
        if Word8
w2 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val1 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2 forall a. Bits a => a -> Int -> a
`shiftL` Int
7), ByteString
r2) else do
         let val2 :: Word64
val2 = (Word64
val1 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w2 forall a. Num a => a -> a -> a
- Word8
0x80) forall a. Bits a => a -> Int -> a
`shiftL` Int
7))

         (Word8
w3,ByteString
r3) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r2
         if Word8
w3 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val2 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w3 forall a. Bits a => a -> Int -> a
`shiftL` Int
14), ByteString
r3) else do
          let val3 :: Word64
val3 = (Word64
val2 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w3 forall a. Num a => a -> a -> a
- Word8
0x80) forall a. Bits a => a -> Int -> a
`shiftL` Int
14))

          (Word8
w4,ByteString
r4) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r3
          if Word8
w4 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val3 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w4 forall a. Bits a => a -> Int -> a
`shiftL` Int
21), ByteString
r4) else do
           let val4 :: Word64
val4 = (Word64
val3 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w4 forall a. Num a => a -> a -> a
- Word8
0x80) forall a. Bits a => a -> Int -> a
`shiftL` Int
21))

           (Word8
w5,ByteString
r5) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r4
           if Word8
w5 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val4 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w5 forall a. Bits a => a -> Int -> a
`shiftL` Int
28), ByteString
r5) else do
            let val5 :: Word64
val5 = (Word64
val4 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w5 forall a. Num a => a -> a -> a
- Word8
0x80) forall a. Bits a => a -> Int -> a
`shiftL` Int
28))

            (Word8
w6,ByteString
r6) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r5
            if Word8
w6 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val5 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w6 forall a. Bits a => a -> Int -> a
`shiftL` Int
35), ByteString
r6) else do
             let val6 :: Word64
val6 = (Word64
val5 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w6 forall a. Num a => a -> a -> a
- Word8
0x80) forall a. Bits a => a -> Int -> a
`shiftL` Int
35))

             (Word8
w7,ByteString
r7) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r6
             if Word8
w7 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val6 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w7 forall a. Bits a => a -> Int -> a
`shiftL` Int
42), ByteString
r7) else do
              let val7 :: Word64
val7 = (Word64
val6 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w7 forall a. Num a => a -> a -> a
- Word8
0x80) forall a. Bits a => a -> Int -> a
`shiftL` Int
42))

              (Word8
w8,ByteString
r8) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r7
              if Word8
w8 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val7 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8 forall a. Bits a => a -> Int -> a
`shiftL` Int
49), ByteString
r8) else do
               let val8 :: Word64
val8 = (Word64
val7 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w8 forall a. Num a => a -> a -> a
- Word8
0x80) forall a. Bits a => a -> Int -> a
`shiftL` Int
49))

               (Word8
w9,ByteString
r9) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r8
               if Word8
w9 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val8 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w9 forall a. Bits a => a -> Int -> a
`shiftL` Int
56), ByteString
r9) else do
                let val9 :: Word64
val9 = (Word64
val8 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w9 forall a. Num a => a -> a -> a
- Word8
0x80) forall a. Bits a => a -> Int -> a
`shiftL` Int
56))

                (Word8
w10,ByteString
r10) <- ByteString -> Either [Char] (Word8, ByteString)
eitherUncons ByteString
r9
                if Word8
w10 forall a. Ord a => a -> a -> Bool
< Word8
128 then forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
val9 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w10 forall a. Bits a => a -> Int -> a
`shiftL` Int
63), ByteString
r10) else do

                 forall a b. a -> Either a b
Left ([Char]
"failed to parse varint128: too big; " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word64
val6)
{-# INLINE takeVarInt #-}


gwireType :: Word8 -> Either String WireType
gwireType :: Word8 -> Either [Char] WireType
gwireType Word8
0 = forall (m :: * -> *) a. Monad m => a -> m a
return WireType
Varint
gwireType Word8
5 = forall (m :: * -> *) a. Monad m => a -> m a
return WireType
Fixed32
gwireType Word8
1 = forall (m :: * -> *) a. Monad m => a -> m a
return WireType
Fixed64
gwireType Word8
2 = forall (m :: * -> *) a. Monad m => a -> m a
return WireType
LengthDelimited
gwireType Word8
wt = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"wireType got unknown wire type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word8
wt
{-# INLINE gwireType #-}

safeSplit :: Int -> B.ByteString -> Either String (B.ByteString, B.ByteString)
safeSplit :: Int -> ByteString -> Either [Char] (ByteString, ByteString)
safeSplit !Int
i !ByteString
b | ByteString -> Int
B.length ByteString
b forall a. Ord a => a -> a -> Bool
< Int
i = forall a b. a -> Either a b
Left [Char]
"failed to parse varint128: not enough bytes"
                | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
i ByteString
b

takeWT :: WireType -> B.ByteString -> Either String (ParsedField, B.ByteString)
takeWT :: WireType -> ByteString -> Either [Char] (ParsedField, ByteString)
takeWT WireType
Varint !ByteString
b  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Word64 -> ParsedField
VarintField) forall a b. (a -> b) -> a -> b
$ ByteString -> Either [Char] (Word64, ByteString)
takeVarInt ByteString
b
takeWT WireType
Fixed32 !ByteString
b = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> ParsedField
Fixed32Field) forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> Either [Char] (ByteString, ByteString)
safeSplit Int
4 ByteString
b
takeWT WireType
Fixed64 !ByteString
b = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> ParsedField
Fixed64Field) forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> Either [Char] (ByteString, ByteString)
safeSplit Int
8 ByteString
b
takeWT WireType
LengthDelimited ByteString
b = do
   (!Word64
len, ByteString
rest) <- ByteString -> Either [Char] (Word64, ByteString)
takeVarInt ByteString
b
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> ParsedField
LengthDelimitedField) forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> Either [Char] (ByteString, ByteString)
safeSplit (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
len) ByteString
rest
{-# INLINE takeWT #-}


-- * Parser Interface

-- | Type describing possible errors that can be encountered while parsing.
data ParseError =
                -- | A 'WireTypeError' occurs when the type of the data in the protobuf
                -- binary format does not match the type encountered by the parser. This can
                -- indicate that the type of a field has changed or is incorrect.
                WireTypeError Text
                |
                -- | A 'BinaryError' occurs when we can't successfully parse the contents of
                -- the field.
                BinaryError Text
                |
                -- | An 'EmbeddedError' occurs when we encounter an error while parsing an
                -- embedded message.
                EmbeddedError Text
                              (Maybe ParseError)
    deriving (Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> [Char]
$cshow :: ParseError -> [Char]
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show, ParseError -> ParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq, Eq ParseError
ParseError -> ParseError -> Bool
ParseError -> ParseError -> Ordering
ParseError -> ParseError -> ParseError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ParseError -> ParseError -> ParseError
$cmin :: ParseError -> ParseError -> ParseError
max :: ParseError -> ParseError -> ParseError
$cmax :: ParseError -> ParseError -> ParseError
>= :: ParseError -> ParseError -> Bool
$c>= :: ParseError -> ParseError -> Bool
> :: ParseError -> ParseError -> Bool
$c> :: ParseError -> ParseError -> Bool
<= :: ParseError -> ParseError -> Bool
$c<= :: ParseError -> ParseError -> Bool
< :: ParseError -> ParseError -> Bool
$c< :: ParseError -> ParseError -> Bool
compare :: ParseError -> ParseError -> Ordering
$ccompare :: ParseError -> ParseError -> Ordering
Ord)

-- | This library does not use this instance, but it is provided for convenience,
-- so that 'ParseError' may be used with functions like `throwIO`
instance Exception ParseError

-- | A parsing function type synonym, to tidy up type signatures.
--
-- This synonym is used in three ways:
--
-- * Applied to 'RawPrimitive', to parse primitive fields.
-- * Applied to 'RawField', to parse fields which correspond to a single 'FieldNumber'.
-- * Applied to 'RawMessage', to parse entire messages.
--
-- Many of the combinators in this module are used to combine and convert between
-- these three parser types.
--
-- 'Parser's can be combined using the 'Applicative', 'Monad' and 'Alternative'
-- instances.
newtype Parser input a = Parser { forall input a. Parser input a -> input -> Either ParseError a
runParser :: input -> Either ParseError a }
    deriving forall a b. a -> Parser input b -> Parser input a
forall a b. (a -> b) -> Parser input a -> Parser input b
forall input a b. a -> Parser input b -> Parser input a
forall input a b. (a -> b) -> Parser input a -> Parser input b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Parser input b -> Parser input a
$c<$ :: forall input a b. a -> Parser input b -> Parser input a
fmap :: forall a b. (a -> b) -> Parser input a -> Parser input b
$cfmap :: forall input a b. (a -> b) -> Parser input a -> Parser input b
Functor

instance Applicative (Parser input) where
    pure :: forall a. a -> Parser input a
pure = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Parser input -> Either ParseError (a -> b)
p1 <*> :: forall a b.
Parser input (a -> b) -> Parser input a -> Parser input b
<*> Parser input -> Either ParseError a
p2 =
        forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$ \input
input -> input -> Either ParseError (a -> b)
p1 input
input forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> input -> Either ParseError a
p2 input
input

instance Monad (Parser input) where
    -- return = pure
    Parser input -> Either ParseError a
p >>= :: forall a b.
Parser input a -> (a -> Parser input b) -> Parser input b
>>= a -> Parser input b
f = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$ \input
input -> input -> Either ParseError a
p input
input forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall input a. Parser input a -> input -> Either ParseError a
`runParser` input
input) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Parser input b
f

-- | Raw data corresponding to a single encoded key/value pair.
type RawPrimitive = ParsedField

-- | Raw data corresponding to a single 'FieldNumber'.
type RawField = [RawPrimitive]

-- | Raw data corresponding to an entire message.
--
-- A 'Map' from 'FieldNumber's to the those values associated with
-- that 'FieldNumber'.
type RawMessage = M.IntMap RawField

-- | Fold over a list of parsed fields accumulating a result
foldFields :: M.IntMap (Parser RawPrimitive a, a -> acc -> acc)
           -> acc
           -> [(FieldNumber, ParsedField)]
           -> Either ParseError acc
foldFields :: forall a acc.
IntMap (Parser ParsedField a, a -> acc -> acc)
-> acc -> [(FieldNumber, ParsedField)] -> Either ParseError acc
foldFields IntMap (Parser ParsedField a, a -> acc -> acc)
parsers = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM acc -> (FieldNumber, ParsedField) -> Either ParseError acc
applyOne
  where applyOne :: acc -> (FieldNumber, ParsedField) -> Either ParseError acc
applyOne acc
acc (FieldNumber
fn, ParsedField
field) =
            case forall a. Int -> IntMap a -> Maybe a
M.lookup (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNumber -> Word64
getFieldNumber forall a b. (a -> b) -> a -> b
$ FieldNumber
fn) IntMap (Parser ParsedField a, a -> acc -> acc)
parsers of
                Maybe (Parser ParsedField a, a -> acc -> acc)
Nothing              -> forall (f :: * -> *) a. Applicative f => a -> f a
pure acc
acc
                Just (Parser ParsedField a
parser, a -> acc -> acc
apply) ->
                    case forall input a. Parser input a -> input -> Either ParseError a
runParser Parser ParsedField a
parser ParsedField
field of
                        Left ParseError
err -> forall a b. a -> Either a b
Left ParseError
err
                        Right a
a  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a -> acc -> acc
apply a
a acc
acc

-- | Parse a message (encoded in the raw wire format) using the specified
-- `Parser`.
parse :: Parser RawMessage a -> B.ByteString -> Either ParseError a
parse :: forall a. Parser RawMessage a -> ByteString -> Either ParseError a
parse Parser RawMessage a
parser ByteString
bs = case ByteString -> Either [Char] RawMessage
decodeWireMessage ByteString
bs of
    Left [Char]
err -> forall a b. a -> Either a b
Left (Text -> ParseError
BinaryError ([Char] -> Text
pack [Char]
err))
    Right RawMessage
res -> forall input a. Parser input a -> input -> Either ParseError a
runParser Parser RawMessage a
parser RawMessage
res
{-# INLINE parse #-}

-- | To comply with the protobuf spec, if there are multiple fields with the same
-- field number, this will always return the last one.
parsedField :: RawField -> Maybe RawPrimitive
parsedField :: [ParsedField] -> Maybe ParsedField
parsedField [ParsedField]
xs = case [ParsedField]
xs of
    [] -> forall a. Maybe a
Nothing
    (ParsedField
x:[ParsedField]
_) -> forall a. a -> Maybe a
Just ParsedField
x

wireTypeError :: String
              -> RawPrimitive
              -> ParseError
wireTypeError :: [Char] -> ParsedField -> ParseError
wireTypeError [Char]
expected ParsedField
wrong = Text -> ParseError
WireTypeError ([Char] -> Text
pack [Char]
msg)
  where
    msg :: [Char]
msg = [Char]
"Wrong wiretype. Expected " forall a. [a] -> [a] -> [a]
++ [Char]
expected forall a. [a] -> [a] -> [a]
++ [Char]
" but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ParsedField
wrong

throwWireTypeError :: String
                   -> RawPrimitive
                   -> Either ParseError expected
throwWireTypeError :: forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
expected ParsedField
wrong =
    forall a b. a -> Either a b
Left ([Char] -> ParsedField -> ParseError
wireTypeError [Char]
expected ParsedField
wrong)
{-# INLINE throwWireTypeError #-}

cerealTypeError :: String -> String -> ParseError
cerealTypeError :: [Char] -> [Char] -> ParseError
cerealTypeError [Char]
expected [Char]
cerealErr = (Text -> ParseError
BinaryError ([Char] -> Text
pack [Char]
msg))
  where
    msg :: [Char]
msg = [Char]
"Failed to parse contents of " forall a. [a] -> [a] -> [a]
++
        [Char]
expected forall a. [a] -> [a] -> [a]
++ [Char]
" field. " forall a. [a] -> [a] -> [a]
++ [Char]
"Error from cereal was: " forall a. [a] -> [a] -> [a]
++ [Char]
cerealErr

throwCerealError :: String -> String -> Either ParseError a
throwCerealError :: forall a. [Char] -> [Char] -> Either ParseError a
throwCerealError [Char]
expected [Char]
cerealErr =
    forall a b. a -> Either a b
Left ([Char] -> [Char] -> ParseError
cerealTypeError [Char]
expected [Char]
cerealErr)
{-# INLINE throwCerealError #-}

parseVarInt :: Integral a => Parser RawPrimitive a
parseVarInt :: forall a. Integral a => Parser ParsedField a
parseVarInt = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        VarintField Word64
i -> forall a b. b -> Either a b
Right (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"varint" ParsedField
wrong

runGetPacked :: Get a -> Parser RawPrimitive a
runGetPacked :: forall a. Get a -> Parser ParsedField a
runGetPacked Get a
g = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        LengthDelimitedField ByteString
bs ->
            case forall a. Get a -> ByteString -> Either [Char] a
runGet Get a
g ByteString
bs of
                Left [Char]
e -> forall a. [Char] -> [Char] -> Either ParseError a
throwCerealError [Char]
"packed repeated field" [Char]
e
                Right a
xs -> forall (m :: * -> *) a. Monad m => a -> m a
return a
xs
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"packed repeated field" ParsedField
wrong

runGetFixed32 :: Get a -> Parser RawPrimitive a
runGetFixed32 :: forall a. Get a -> Parser ParsedField a
runGetFixed32 Get a
g = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        Fixed32Field ByteString
bs -> case forall a. Get a -> ByteString -> Either [Char] a
runGet Get a
g ByteString
bs of
            Left [Char]
e -> forall a. [Char] -> [Char] -> Either ParseError a
throwCerealError [Char]
"fixed32 field" [Char]
e
            Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"fixed 32 field" ParsedField
wrong

runGetFixed64 :: Get a -> Parser RawPrimitive a
runGetFixed64 :: forall a. Get a -> Parser ParsedField a
runGetFixed64 Get a
g = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        Fixed64Field ByteString
bs -> case forall a. Get a -> ByteString -> Either [Char] a
runGet Get a
g ByteString
bs of
            Left [Char]
e -> forall a. [Char] -> [Char] -> Either ParseError a
throwCerealError [Char]
"fixed 64 field" [Char]
e
            Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"fixed 64 field" ParsedField
wrong

bytes :: Parser RawPrimitive B.ByteString
bytes :: Parser ParsedField ByteString
bytes = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        LengthDelimitedField ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString
B.copy ByteString
bs
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"bytes" ParsedField
wrong

-- | Parse a Boolean value.
bool :: Parser RawPrimitive Bool
bool :: Parser ParsedField Bool
bool = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        VarintField Word64
i -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Word64
i forall a. Eq a => a -> a -> Bool
/= Word64
0
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"bool" ParsedField
wrong

-- | Parse a primitive with the @int32@ wire type.
int32 :: Parser RawPrimitive Int32
int32 :: Parser ParsedField Int32
int32 = forall a. Integral a => Parser ParsedField a
parseVarInt

-- | Parse a primitive with the @int64@ wire type.
int64 :: Parser RawPrimitive Int64
int64 :: Parser ParsedField Int64
int64 = forall a. Integral a => Parser ParsedField a
parseVarInt

-- | Parse a primitive with the @uint32@ wire type.
uint32 :: Parser RawPrimitive Word32
uint32 :: Parser ParsedField Word32
uint32 = forall a. Integral a => Parser ParsedField a
parseVarInt

-- | Parse a primitive with the @uint64@ wire type.
uint64 :: Parser RawPrimitive Word64
uint64 :: Parser ParsedField Word64
uint64 = forall a. Integral a => Parser ParsedField a
parseVarInt

-- | Parse a primitive with the @sint32@ wire type.
sint32 :: Parser RawPrimitive Int32
sint32 :: Parser ParsedField Int32
sint32 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (Num a, Bits a) => a -> a
zigZagDecode :: Word32 -> Word32)) forall a. Integral a => Parser ParsedField a
parseVarInt

-- | Parse a primitive with the @sint64@ wire type.
sint64 :: Parser RawPrimitive Int64
sint64 :: Parser ParsedField Int64
sint64 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. (Num a, Bits a) => a -> a
zigZagDecode :: Word64 -> Word64)) forall a. Integral a => Parser ParsedField a
parseVarInt

-- | Parse a primitive with the @bytes@ wire type as a 'B.ByteString'.
byteString :: Parser RawPrimitive B.ByteString
byteString :: Parser ParsedField ByteString
byteString = Parser ParsedField ByteString
bytes

-- | Parse a primitive with the @bytes@ wire type as a lazy 'BL.ByteString'.
lazyByteString :: Parser RawPrimitive BL.ByteString
lazyByteString :: Parser ParsedField ByteString
lazyByteString = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BL.fromStrict Parser ParsedField ByteString
bytes

-- | Parse a primitive with the @bytes@ wire type as a 'BS.ShortByteString'.
shortByteString :: Parser RawPrimitive BS.ShortByteString
shortByteString :: Parser ParsedField ShortByteString
shortByteString = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        LengthDelimitedField ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString -> ShortByteString
BS.toShort ByteString
bs
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"bytes" ParsedField
wrong

-- | Parse a primitive with the @bytes@ wire type as 'Text'.
text :: Parser RawPrimitive Text
text :: Parser ParsedField Text
text = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        LengthDelimitedField ByteString
bs ->
            case ByteString -> Either UnicodeException Text
decodeUtf8' forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
bs of
                Left UnicodeException
err -> forall a b. a -> Either a b
Left (Text -> ParseError
BinaryError ([Char] -> Text
pack ([Char]
"Failed to decode UTF-8: " forall a. [a] -> [a] -> [a]
++
                                                         forall a. Show a => a -> [Char]
show UnicodeException
err)))
                Right Text
txt -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
txt
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"string" ParsedField
wrong

-- | Parse a primitive with the @bytes@ wire type as `Text.Short.ShortText`.
shortText :: Parser RawPrimitive Text.Short.ShortText
shortText :: Parser ParsedField ShortText
shortText = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        LengthDelimitedField ByteString
bs ->
            case ByteString -> Maybe ShortText
Text.Short.fromByteString ByteString
bs of
                Maybe ShortText
Nothing -> forall a b. a -> Either a b
Left (Text -> ParseError
BinaryError ([Char] -> Text
pack ([Char]
"Failed to decode UTF-8")))
                Just ShortText
txt -> forall (m :: * -> *) a. Monad m => a -> m a
return ShortText
txt
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"string" ParsedField
wrong

-- | Parse a primitive with an enumerated type.
--
-- This parser will return 'Left' if the encoded integer value
-- is not a code for a known enumerator.
enum :: forall e. ProtoEnum e => Parser RawPrimitive (Either Int32 e)
enum :: forall e. ProtoEnum e => Parser ParsedField (Either Int32 e)
enum = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Either Int32 e
toEither forall a. Integral a => Parser ParsedField a
parseVarInt
  where
    toEither :: Int32 -> Either Int32 e
    toEither :: Int32 -> Either Int32 e
toEither Int32
i
      | Just e
e <- forall a. ProtoEnum a => Int32 -> Maybe a
toProtoEnumMay Int32
i = forall a b. b -> Either a b
Right e
e
      | Bool
otherwise = forall a b. a -> Either a b
Left Int32
i

-- | Parse a packed collection of variable-width integer values (any of @int32@,
-- @int64@, @sint32@, @sint64@, @uint32@, @uint64@ or enumerations).
packedVarints :: Integral a => Parser RawPrimitive [a]
packedVarints :: forall a. Integral a => Parser ParsedField [a]
packedVarints = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral) (forall a. Get a -> Parser ParsedField a
runGetPacked (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get Word64
getBase128Varint))

getBase128Varint :: Get Word64
getBase128Varint :: Get Word64
getBase128Varint = forall {t}. (Bits t, Num t) => Int -> t -> Get t
loop Int
0 Word64
0
  where
    loop :: Int -> t -> Get t
loop !Int
i !t
w64 = do
        Word8
w8 <- Get Word8
getWord8
        if forall {p}. Bits p => p -> Bool
base128Terminal Word8
w8
            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a} {a}.
(Integral a, Bits a, Bits a, Num a) =>
Int -> a -> a -> a
combine Int
i t
w64 Word8
w8
            else Int -> t -> Get t
loop (Int
i forall a. Num a => a -> a -> a
+ Int
1) (forall {a} {a}.
(Integral a, Bits a, Bits a, Num a) =>
Int -> a -> a -> a
combine Int
i t
w64 Word8
w8)
    base128Terminal :: p -> Bool
base128Terminal p
w8 = (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Bits a => a -> Int -> Bool
`testBit` Int
7)) forall a b. (a -> b) -> a -> b
$ p
w8
    combine :: Int -> a -> a -> a
combine Int
i a
w64 a
w8 = (a
w64 forall a. Bits a => a -> a -> a
.|.
                            (forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
w8 forall a. Bits a => a -> Int -> a
`clearBit` Int
7)
                             forall a. Bits a => a -> Int -> a
`shiftL`
                             (Int
i forall a. Num a => a -> a -> a
* Int
7)))



-- | Parse a packed collection of @float@ values.
packedFloats :: Parser RawPrimitive [Float]
packedFloats :: Parser ParsedField [Float]
packedFloats = forall a. Get a -> Parser ParsedField a
runGetPacked (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get Float
getFloat32le)

-- | Parse a packed collection of @double@ values.
packedDoubles :: Parser RawPrimitive [Double]
packedDoubles :: Parser ParsedField [Double]
packedDoubles = forall a. Get a -> Parser ParsedField a
runGetPacked (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get Double
getFloat64le)

-- | Parse a packed collection of @fixed32@ values.
packedFixed32 :: Integral a => Parser RawPrimitive [a]
packedFixed32 :: forall a. Integral a => Parser ParsedField [a]
packedFixed32 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral) (forall a. Get a -> Parser ParsedField a
runGetPacked (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get Word32
getWord32le))

-- | Parse a packed collection of @fixed64@ values.
packedFixed64 :: Integral a => Parser RawPrimitive [a]
packedFixed64 :: forall a. Integral a => Parser ParsedField [a]
packedFixed64 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral) (forall a. Get a -> Parser ParsedField a
runGetPacked (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get Word64
getWord64le))

-- | Parse a @float@.
float :: Parser RawPrimitive Float
float :: Parser ParsedField Float
float = forall a. Get a -> Parser ParsedField a
runGetFixed32 Get Float
getFloat32le

-- | Parse a @double@.
double :: Parser RawPrimitive Double
double :: Parser ParsedField Double
double = forall a. Get a -> Parser ParsedField a
runGetFixed64 Get Double
getFloat64le

-- | Parse an integer primitive with the @fixed32@ wire type.
fixed32 :: Parser RawPrimitive Word32
fixed32 :: Parser ParsedField Word32
fixed32 = forall a. Get a -> Parser ParsedField a
runGetFixed32 Get Word32
getWord32le

-- | Parse an integer primitive with the @fixed64@ wire type.
fixed64 :: Parser RawPrimitive Word64
fixed64 :: Parser ParsedField Word64
fixed64 = forall a. Get a -> Parser ParsedField a
runGetFixed64 Get Word64
getWord64le

-- | Parse a signed integer primitive with the @fixed32@ wire type.
sfixed32 :: Parser RawPrimitive Int32
sfixed32 :: Parser ParsedField Int32
sfixed32 = forall a. Get a -> Parser ParsedField a
runGetFixed32 Get Int32
getInt32le

-- | Parse a signed integer primitive with the @fixed64@ wire type.
sfixed64 :: Parser RawPrimitive Int64
sfixed64 :: Parser ParsedField Int64
sfixed64 = forall a. Get a -> Parser ParsedField a
runGetFixed64 Get Int64
getInt64le

-- | Turn a field parser into a message parser, by specifying the 'FieldNumber'.
--
-- This parser will fail if the specified 'FieldNumber' is not present.
--
-- For example:
--
-- > one float `at` fieldNumber 1 :: Parser RawMessage (Maybe Float)
at :: Parser RawField a -> FieldNumber -> Parser RawMessage a
at :: forall a.
Parser [ParsedField] a -> FieldNumber -> Parser RawMessage a
at Parser [ParsedField] a
parser FieldNumber
fn = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$ forall input a. Parser input a -> input -> Either ParseError a
runParser Parser [ParsedField] a
parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IntMap a -> Maybe a
M.lookup (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNumber -> Word64
getFieldNumber forall a b. (a -> b) -> a -> b
$ FieldNumber
fn)
{-# INLINE at #-}

-- | Try to parse different field numbers with their respective parsers. This is
-- used to express alternative between possible fields of a oneof.
--
-- TODO: contrary to the protobuf spec, in the case of multiple fields number
-- matching the oneof content, the choice of field is biased to the order of the
-- list, instead of being biased to the last field of group of field number in
-- the oneof. This is related to the Map used for input that preserve order
-- across multiple invocation of the same field, but not across a group of
-- field.
oneof :: a
         -- ^ The value to produce when no field numbers belonging to the oneof
         -- are present in the input
      -> [(FieldNumber, Parser RawField a)]
         -- ^ Left-biased oneof field parsers, one per field number belonging to
         -- the oneof
      -> Parser RawMessage a
oneof :: forall a.
a -> [(FieldNumber, Parser [ParsedField] a)] -> Parser RawMessage a
oneof a
def [(FieldNumber, Parser [ParsedField] a)]
parsersByFieldNum = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$ \RawMessage
input ->
  case forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((\(FieldNumber
num,Parser [ParsedField] a
p) -> (Parser [ParsedField] a
p,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> IntMap a -> Maybe a
M.lookup (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldNumber -> Word64
getFieldNumber forall a b. (a -> b) -> a -> b
$ FieldNumber
num) RawMessage
input) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FieldNumber, Parser [ParsedField] a)]
parsersByFieldNum) of
    Maybe (Parser [ParsedField] a, [ParsedField])
Nothing     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
    Just (Parser [ParsedField] a
p, [ParsedField]
v) -> forall input a. Parser input a -> input -> Either ParseError a
runParser Parser [ParsedField] a
p [ParsedField]
v

-- | This turns a primitive parser into a field parser by keeping the
-- last received value, or return a default value if the field number is missing.
--
-- Used to ensure that we return the last value with the given field number
-- in the message, in compliance with the protobuf standard.
--
-- The protocol buffers specification specifies default values for
-- primitive types.
--
-- For example:
--
-- > one float 0 :: Parser RawField Float
one :: Parser RawPrimitive a -> a -> Parser RawField a
one :: forall a. Parser ParsedField a -> a -> Parser [ParsedField] a
one Parser ParsedField a
parser a
def = forall input a. (input -> Either ParseError a) -> Parser input a
Parser (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe a
def) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall input a. Parser input a -> input -> Either ParseError a
runParser Parser ParsedField a
parser) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParsedField] -> Maybe ParsedField
parsedField)

-- | Parse a repeated field, or an unpacked collection of primitives.
--
-- Each value with the identified 'FieldNumber' will be passed to the parser
-- in the first argument, to be converted into a value of the correct type.
--
-- For example, to parse a packed collection of @uint32@ values:
--
-- > repeated uint32 :: Parser RawField ([Word32])
--
-- or to parse a collection of embedded messages:
--
-- > repeated . embedded' :: Parser RawMessage a -> Parser RawField ([a])
repeated :: Parser RawPrimitive a -> Parser RawField [a]
repeated :: forall a. Parser ParsedField a -> Parser [ParsedField] [a]
repeated Parser ParsedField a
parser = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall input a. Parser input a -> input -> Either ParseError a
runParser Parser ParsedField a
parser)


embeddedParseError :: String -> ParseError
embeddedParseError :: [Char] -> ParseError
embeddedParseError [Char]
err = Text -> Maybe ParseError -> ParseError
EmbeddedError Text
msg forall a. Maybe a
Nothing
  where
    msg :: Text
msg = Text
"Failed to parse embedded message: " forall a. Semigroup a => a -> a -> a
<> ([Char] -> Text
pack [Char]
err)
{-# NOINLINE embeddedParseError #-}

-- | For a field containing an embedded message, parse as far as getting the
-- wire-level fields out of the message.
embeddedToParsedFields :: RawPrimitive -> Either ParseError RawMessage
embeddedToParsedFields :: ParsedField -> Either ParseError RawMessage
embeddedToParsedFields (LengthDelimitedField ByteString
bs) =
    case ByteString -> Either [Char] RawMessage
decodeWireMessage ByteString
bs of
        Left [Char]
err -> forall a b. a -> Either a b
Left ([Char] -> ParseError
embeddedParseError [Char]
err)
        Right RawMessage
result -> forall a b. b -> Either a b
Right RawMessage
result
embeddedToParsedFields ParsedField
wrong =
    forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"embedded" ParsedField
wrong

-- | Create a field parser for an embedded message, from a message parser.
--
-- The protobuf spec requires that embedded messages be mergeable, so that
-- protobuf encoding has the flexibility to transmit embedded messages in
-- pieces. This function reassembles the pieces, and must be used to parse all
-- embedded non-repeated messages.
--
-- If the embedded message is not found in the outer message, this function
-- returns 'Nothing'.
embedded :: Parser RawMessage a -> Parser RawField (Maybe a)
embedded :: forall a. Parser RawMessage a -> Parser [ParsedField] (Maybe a)
embedded Parser RawMessage a
p = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \[ParsedField]
xs -> if [ParsedField]
xs forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a. Alternative f => f a
empty
           then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           else do
               [RawMessage]
innerMaps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM ParsedField -> Either ParseError RawMessage
embeddedToParsedFields [ParsedField]
xs
               let combinedMap :: RawMessage
combinedMap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
M.unionWith forall a. Semigroup a => a -> a -> a
(<>)) forall a. IntMap a
M.empty [RawMessage]
innerMaps
               a
parsed <- forall input a. Parser input a -> input -> Either ParseError a
runParser Parser RawMessage a
p RawMessage
combinedMap
               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
parsed
{-# INLINE embedded #-}

-- | Create a primitive parser for an embedded message from a message parser.
--
-- This parser does no merging of fields if multiple message fragments are
-- sent separately.
embedded' :: Parser RawMessage a -> Parser RawPrimitive a
embedded' :: forall a. Parser RawMessage a -> Parser ParsedField a
embedded' Parser RawMessage a
parser = forall input a. (input -> Either ParseError a) -> Parser input a
Parser forall a b. (a -> b) -> a -> b
$
    \case
        LengthDelimitedField ByteString
bs ->
            case forall a. Parser RawMessage a -> ByteString -> Either ParseError a
parse Parser RawMessage a
parser ByteString
bs of
                Left ParseError
err -> forall a b. a -> Either a b
Left (Text -> Maybe ParseError -> ParseError
EmbeddedError Text
"Failed to parse embedded message." (forall a. a -> Maybe a
Just ParseError
err))
                Right a
result -> forall (m :: * -> *) a. Monad m => a -> m a
return a
result
        ParsedField
wrong -> forall expected.
[Char] -> ParsedField -> Either ParseError expected
throwWireTypeError [Char]
"embedded" ParsedField
wrong
{-# INLINE embedded' #-}



-- TODO test repeated and embedded better for reverse logic...