-- Copyright 2016 Google Inc. All Rights Reserved.
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd

{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
-- | Datatypes for reflection of protocol buffer messages.
module Data.ProtoLens.Message (
    -- * Reflection of Messages
    Message(..),
    Tag(..),
    allFields,
    FieldDescriptor(..),
    fieldDescriptorName,
    isRequired,
    FieldAccessor(..),
    WireDefault(..),
    Packing(..),
    FieldTypeDescriptor(..),
    ScalarField(..),
    MessageOrGroup(..),
    FieldDefault(..),
    MessageEnum(..),
    -- * Constructing protocol buffers
    build,
    -- * Proto registries
    Registry,
    register,
    lookupRegistered,
    SomeMessageType(..),
    -- * Any messages
    matchAnyMessage,
    AnyMessageDescriptor(..),
    -- * Utilities for constructing protocol buffer lenses
    maybeLens,
    -- * Internal utilities for parsing protocol buffers
    reverseRepeatedFields,
    -- * Unknown fields
    FieldSet,
    TaggedValue(..),
    discardUnknownFields,
    ) where

import qualified Data.ByteString as B
import Data.Int
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(..))
import qualified Data.Text as T
import Data.Word
import Lens.Family2 (Lens', over, set)
import Lens.Family2.Unchecked (lens)
import qualified Data.Semigroup as Semigroup

import Data.ProtoLens.Encoding.Bytes (Builder, Parser)
import Data.ProtoLens.Encoding.Wire
    ( Tag(..)
    , TaggedValue(..)
    )

-- | Every protocol buffer is an instance of 'Message'.  This class enables
-- serialization by providing reflection of all of the fields that may be used
-- by this type.
class Message msg where
    -- | A unique identifier for this type, of the format
    -- @"packagename.messagename"@.
    messageName :: Proxy msg -> T.Text

    -- | The serialized protobuffer message descriptor for this type.
    --
    -- For a friendlier version which returns the actual descriptor type,
    -- use @Data.ProtoLens.Descriptor.messageDescriptor@
    -- from the @proto-lens-protobuf-types@ package.
    packedMessageDescriptor :: Proxy msg -> B.ByteString

    -- | The serialized protobuffer file message descriptor containing this type.
    --
    -- For a friendlier version which returns the actual file descriptor type,
    -- use @Data.ProtoLens.Descriptor.fileDescriptor@
    -- from the @proto-lens-protobuf-types@ package.
    packedFileDescriptor :: Proxy msg -> B.ByteString

    -- | A message with all fields set to their default values.
    --
    -- Satisfies @encodeMessage defMessage == ""@ and @decodeMessage "" == Right defMessage@.
    defMessage :: msg

    -- | The fields of the proto, indexed by their (integer) tag.
    fieldsByTag :: Map Tag (FieldDescriptor msg)

    -- | This map is keyed by the name of the field used for text format protos.
    -- This is just the field name for every field except for group fields,
    -- which use their Message type name in text protos instead of their
    -- field name. For example, "optional group Foo" has the field name "foo"
    -- but in this map it is stored with the key "Foo".
    fieldsByTextFormatName :: Map String (FieldDescriptor msg)
    fieldsByTextFormatName =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
n, FieldDescriptor msg
f) | f :: FieldDescriptor msg
f@(FieldDescriptor String
n FieldTypeDescriptor value
_ FieldAccessor msg value
_) <- forall msg. Message msg => [FieldDescriptor msg]
allFields]

    -- | Access the unknown fields of a Message.
    unknownFields :: Lens' msg FieldSet

    -- | Decode a message value.
    --
    -- See also the functions in "Data.ProtoLens.Encoding".
    parseMessage :: Parser msg

    -- | Encode a message value.
    --
    -- See also the functions in "Data.ProtoLens.Encoding".
    buildMessage :: msg -> Builder

allFields :: Message msg => [FieldDescriptor msg]
allFields :: forall msg. Message msg => [FieldDescriptor msg]
allFields = forall k a. Map k a -> [a]
Map.elems forall msg. Message msg => Map Tag (FieldDescriptor msg)
fieldsByTag

-- TODO: represent FieldSet as a Vector too.
type FieldSet = [TaggedValue]

-- | A description of a specific field of a protocol buffer.
--
-- 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
                    -> FieldTypeDescriptor value -> FieldAccessor msg value
                    -> FieldDescriptor msg

-- | The original name of the field in the .proto file.
fieldDescriptorName :: FieldDescriptor msg -> String
fieldDescriptorName :: forall msg. FieldDescriptor msg -> String
fieldDescriptorName (FieldDescriptor String
name FieldTypeDescriptor value
_ FieldAccessor msg value
_) = String
name

-- | Whether the given field is required.  Specifically, if its 'FieldAccessor'
-- is a 'Required' 'PlainField'.
isRequired :: FieldDescriptor msg -> Bool
isRequired :: forall msg. FieldDescriptor msg -> Bool
isRequired (FieldDescriptor String
_ FieldTypeDescriptor value
_ (PlainField WireDefault value
Required Lens' msg value
_)) = Bool
True
isRequired FieldDescriptor msg
_ = Bool
False

-- | A Lens for accessing the value of an individual field in a protocol buffer
-- message.
data FieldAccessor msg value where
    -- A field which is stored in the proto as just a value.  Used for
    -- required fields and proto3 optional scalar fields.
    PlainField :: WireDefault value -> Lens' msg value
                     -> FieldAccessor msg value
    -- An optional field where the "unset" and "default" values are
    -- distinguishable.  In particular: proto2 optional fields, proto3
    -- messages, and "oneof" fields.
    OptionalField :: Lens' msg (Maybe value) -> FieldAccessor msg value
    RepeatedField :: Packing -> Lens' msg [value] -> FieldAccessor msg value
    -- A proto "map" field is serialized as a repeated field of an
    -- autogenerated "entry" type, where each entry contains a single key/value
    -- pair.  This constructor provides lenses for accessing the key and value
    -- of each entry, so that we can covert between a list of entries and a Map.
    MapField :: (Ord key, Message entry) => Lens' entry key -> Lens' entry value
                      -> Lens' msg (Map key value) -> FieldAccessor msg entry

-- | The default value (if any) for a 'PlainField' on the wire.
data WireDefault value where
    -- Required fields have no default.
    Required :: WireDefault value
    -- Corresponds to proto3 scalar fields.
    Optional :: (FieldDefault value, Eq value) => WireDefault value

-- | A proto3 field type with an implicit default value.
--
-- This is distinct from, say, 'Data.Default' to avoid orphan instances, and
-- because 'Bool' doesn't necessarily have a good Default instance for general
-- usage.
class FieldDefault value where
    fieldDefault :: value

instance FieldDefault Bool where
    fieldDefault :: Bool
fieldDefault = Bool
False

instance FieldDefault Int32 where
    fieldDefault :: Int32
fieldDefault = Int32
0

instance FieldDefault Int64 where
    fieldDefault :: Int64
fieldDefault = Int64
0

instance FieldDefault Word32 where
    fieldDefault :: Word32
fieldDefault = Word32
0

instance FieldDefault Word64 where
    fieldDefault :: Word64
fieldDefault = Word64
0

instance FieldDefault Float where
    fieldDefault :: Float
fieldDefault = Float
0

instance FieldDefault Double where
    fieldDefault :: Double
fieldDefault = Double
0

instance FieldDefault B.ByteString where
    fieldDefault :: ByteString
fieldDefault = ByteString
B.empty

instance FieldDefault T.Text where
    fieldDefault :: Text
fieldDefault = Text
T.empty

-- | How a given repeated field is transmitted on the wire format.
data Packing = Packed | Unpacked

-- | A description of the type of a given field value.
data FieldTypeDescriptor value where
    MessageField :: Message value => MessageOrGroup -> FieldTypeDescriptor value
    ScalarField :: ScalarField value -> FieldTypeDescriptor value

deriving instance Show (FieldTypeDescriptor value)

data MessageOrGroup = MessageType | GroupType
    deriving Int -> MessageOrGroup -> ShowS
[MessageOrGroup] -> ShowS
MessageOrGroup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageOrGroup] -> ShowS
$cshowList :: [MessageOrGroup] -> ShowS
show :: MessageOrGroup -> String
$cshow :: MessageOrGroup -> String
showsPrec :: Int -> MessageOrGroup -> ShowS
$cshowsPrec :: Int -> MessageOrGroup -> ShowS
Show

data ScalarField t where
    EnumField :: MessageEnum value => ScalarField value
    Int32Field :: ScalarField Int32
    Int64Field :: ScalarField Int64
    UInt32Field :: ScalarField Word32
    UInt64Field :: ScalarField Word64
    SInt32Field :: ScalarField Int32
    SInt64Field :: ScalarField Int64
    Fixed32Field :: ScalarField Word32
    Fixed64Field :: ScalarField Word64
    SFixed32Field :: ScalarField Int32
    SFixed64Field :: ScalarField Int64
    FloatField :: ScalarField Float
    DoubleField :: ScalarField Double
    BoolField :: ScalarField Bool
    StringField :: ScalarField T.Text
    BytesField :: ScalarField B.ByteString

deriving instance Show (ScalarField value)

matchAnyMessage :: forall value . FieldTypeDescriptor value -> Maybe (AnyMessageDescriptor value)
matchAnyMessage :: forall value.
FieldTypeDescriptor value -> Maybe (AnyMessageDescriptor value)
matchAnyMessage (MessageField MessageOrGroup
_)
    | forall msg. Message msg => Proxy msg -> Text
messageName (forall {k} (t :: k). Proxy t
Proxy @value) forall a. Eq a => a -> a -> Bool
== Text
"google.protobuf.Any"
    , Just (FieldDescriptor String
_ (ScalarField ScalarField value
StringField) (PlainField WireDefault value
Optional Lens' value value
typeUrlLens))
        <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Tag
1 (forall msg. Message msg => Map Tag (FieldDescriptor msg)
fieldsByTag @value)
    , Just (FieldDescriptor String
_ (ScalarField ScalarField value
BytesField) (PlainField WireDefault value
Optional Lens' value value
valueLens))
        <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Tag
2 (forall msg. Message msg => Map Tag (FieldDescriptor msg)
fieldsByTag @value)
        = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall msg.
Lens' msg Text -> Lens' msg ByteString -> AnyMessageDescriptor msg
AnyMessageDescriptor Lens' value value
typeUrlLens Lens' value value
valueLens
matchAnyMessage FieldTypeDescriptor value
_ = forall a. Maybe a
Nothing

data AnyMessageDescriptor msg
    = AnyMessageDescriptor
        { forall msg. AnyMessageDescriptor msg -> Lens' msg Text
anyTypeUrlLens :: Lens' msg T.Text
        , forall msg. AnyMessageDescriptor msg -> Lens' msg ByteString
anyValueLens :: Lens' msg B.ByteString
        }

-- | A class for protocol buffer enums that enables safe decoding.
class (Enum a, Bounded a) => MessageEnum a where
    -- | Convert the given 'Int' to an enum value.  Returns 'Nothing' if
    -- no corresponding value was defined in the .proto file.
    maybeToEnum :: Int -> Maybe a
    -- | Get the name of this enum as defined in the .proto file.  Used
    -- for the human-readable output in @Data.ProtoLens.TextFormat@.
    showEnum :: a -> String
    -- | Convert the given 'String' to an enum value. Returns 'Nothing' if
    -- no corresponding value was defined in the .proto file.
    readEnum :: String -> Maybe a

-- | Utility function for building a message from a default value.
-- For example:
--
-- > instance Default A where ...
-- > x, y :: Lens' A Int
-- > m :: A
-- > m = build ((x .~ 5) . (y .~ 7))
build :: Message a => (a -> a) -> a
build :: forall a. Message a => (a -> a) -> a
build = (forall a b. (a -> b) -> a -> b
$ forall msg. Message msg => msg
defMessage)

-- | A helper lens for accessing optional fields.
-- This is used as part of code generation, and should generally not be needed
-- explicitly.
--
-- Note that 'maybeLens' does not satisfy the lens laws, which expect that @set
-- l (view l x) == x@.  For example,
--
-- > set (maybeLens 'a') (view (maybeLens 'a') Nothing) == Just 'a'
--
-- However, this is the behavior generally expected by users, and only matters
-- if we're explicitly checking whether a field is set.
maybeLens :: b -> Lens' (Maybe b) b
maybeLens :: forall b. b -> Lens' (Maybe b) b
maybeLens b
x = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (forall a. a -> Maybe a -> a
fromMaybe b
x) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a. a -> Maybe a
Just
-- | Reverse every repeated (list) field in the message.
--
-- During parsing, we store fields temporarily in reverse order,
-- and then un-reverse them at the end.  This helps avoid the quadratic blowup
-- from repeatedly appending to lists.
-- TODO: Benchmark how much of a problem this is in practice,
-- and whether it's still a net win for small protobufs.
-- If we decide on it more permanently, consider moving it to a more internal
-- module.
reverseRepeatedFields :: Map k (FieldDescriptor msg) -> msg -> msg
reverseRepeatedFields :: forall k msg. Map k (FieldDescriptor msg) -> msg -> msg
reverseRepeatedFields Map k (FieldDescriptor msg)
fields msg
x0
    -- TODO: if it becomes a bottleneck, consider forcing
    -- the full spine of each list.
    = forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' forall a. a -> FieldDescriptor a -> a
reverseListField msg
x0 Map k (FieldDescriptor msg)
fields
  where
    reverseListField :: a -> FieldDescriptor a -> a
    reverseListField :: forall a. a -> FieldDescriptor a -> a
reverseListField a
x (FieldDescriptor String
_ FieldTypeDescriptor value
_ (RepeatedField Packing
_ Lens' a [value]
f))
        = forall s t a b. Setter s t a b -> (a -> b) -> s -> t
over Lens' a [value]
f forall a. [a] -> [a]
reverse a
x
    reverseListField a
x FieldDescriptor a
_ = a
x

-- | A set of known message types. Can help encode/decode protobufs containing
-- @Data.ProtoLens.Any@ values in a more human-readable text format.
--
-- Registries can be combined using their 'Monoid' instance.
--
-- See the @withRegistry@ functions in 'Data.ProtoLens.TextFormat'
newtype Registry = Registry (Map.Map T.Text SomeMessageType)
    deriving (NonEmpty Registry -> Registry
Registry -> Registry -> Registry
forall b. Integral b => b -> Registry -> Registry
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Registry -> Registry
$cstimes :: forall b. Integral b => b -> Registry -> Registry
sconcat :: NonEmpty Registry -> Registry
$csconcat :: NonEmpty Registry -> Registry
<> :: Registry -> Registry -> Registry
$c<> :: Registry -> Registry -> Registry
Semigroup.Semigroup, Semigroup Registry
Registry
[Registry] -> Registry
Registry -> Registry -> Registry
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Registry] -> Registry
$cmconcat :: [Registry] -> Registry
mappend :: Registry -> Registry -> Registry
$cmappend :: Registry -> Registry -> Registry
mempty :: Registry
$cmempty :: Registry
Monoid)

-- | Build a 'Registry' containing a single proto type.
--
--   Example:
-- > register (Proxy :: Proxy Proto.My.Proto.Type)
register :: forall msg . Message msg => Proxy msg -> Registry
register :: forall msg. Message msg => Proxy msg -> Registry
register Proxy msg
p = Map Text SomeMessageType -> Registry
Registry forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (forall msg. Message msg => Proxy msg -> Text
messageName (forall {k} (t :: k). Proxy t
Proxy @msg)) (forall msg. Message msg => Proxy msg -> SomeMessageType
SomeMessageType Proxy msg
p)

-- | Look up a message type by name (e.g.,
-- @"type.googleapis.com/google.protobuf.FloatValue"@). The URL corresponds to
-- the field @google.protobuf.Any.type_url@.
lookupRegistered :: T.Text -> Registry -> Maybe SomeMessageType
lookupRegistered :: Text -> Registry -> Maybe SomeMessageType
lookupRegistered Text
n (Registry Map Text SomeMessageType
m) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd Text
"/" Text
n) Map Text SomeMessageType
m

data SomeMessageType where
    SomeMessageType :: Message msg => Proxy msg -> SomeMessageType

-- TODO: recursively
discardUnknownFields :: Message msg => msg -> msg
discardUnknownFields :: forall msg. Message msg => msg -> msg
discardUnknownFields = forall s t a b. Setter s t a b -> b -> s -> t
set forall msg. Message msg => Lens' msg FieldSet
unknownFields []