module Tendermint.SDK.Types.Message where

import           Control.Lens                   (Wrapped (..), from, iso, view,
                                                 ( # ), (&), (.~), (^.))
import           Data.Bifunctor                 (bimap)
import           Data.ByteString                (ByteString)
import qualified Data.ProtoLens                 as P
import           Data.Proxy
import           Data.String.Conversions        (cs)
import           Data.Text                      (Text)
import qualified Data.Validation                as V
import qualified Proto.Types.Transaction        as T
import qualified Proto.Types.Transaction_Fields as T
import qualified Proto3.Wire.Decode             as Wire
import           Tendermint.SDK.Codec           (HasCodec (..))
import           Tendermint.SDK.Types.Address   (Address)

-- | The basic message format embedded in any transaction.
data Msg msg = Msg
  { Msg msg -> Address
msgAuthor :: Address
  , Msg msg -> msg
msgData   :: msg
  , Msg msg -> Text
msgType   :: Text
  }

instance Functor Msg where
  fmap :: (a -> b) -> Msg a -> Msg b
fmap f :: a -> b
f msg :: Msg a
msg@Msg{a
msgData :: a
msgData :: forall msg. Msg msg -> msg
msgData} = Msg a
msg {msgData :: b
msgData = a -> b
f a
msgData}

class HasMessageType msg where
  messageType :: Proxy msg -> Text

data TypedMessage = TypedMessage
  { TypedMessage -> ByteString
typedMsgData :: ByteString
  , TypedMessage -> Text
typedMsgType :: Text
  }

instance Wrapped TypedMessage where
  type Unwrapped TypedMessage = T.TypedMessage

  _Wrapped' :: p (Unwrapped TypedMessage) (f (Unwrapped TypedMessage))
-> p TypedMessage (f TypedMessage)
_Wrapped' = (TypedMessage -> TypedMessage)
-> (TypedMessage -> TypedMessage)
-> Iso TypedMessage TypedMessage TypedMessage TypedMessage
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso TypedMessage -> TypedMessage
forall b.
(Message b, HasField b "data'" ByteString,
 HasField b "type'" Text) =>
TypedMessage -> b
t TypedMessage -> TypedMessage
forall s.
(HasField s "data'" ByteString, HasField s "type'" Text) =>
s -> TypedMessage
f
   where
    t :: TypedMessage -> b
t TypedMessage {..} =
      b
forall msg. Message msg => msg
P.defMessage
        b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& LensLike' Identity b ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "data'" a) =>
LensLike' f s a
T.data' LensLike' Identity b ByteString -> ByteString -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ByteString
typedMsgData
        b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& LensLike' Identity b Text
forall (f :: * -> *) s a.
(Functor f, HasField s "type'" a) =>
LensLike' f s a
T.type' LensLike' Identity b Text -> Text -> b -> b
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
typedMsgType
    f :: s -> TypedMessage
f message :: s
message = TypedMessage :: ByteString -> Text -> TypedMessage
TypedMessage
      { typedMsgData :: ByteString
typedMsgData = s
message s -> Getting ByteString s ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString s ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "data'" a) =>
LensLike' f s a
T.data'
      , typedMsgType :: Text
typedMsgType = s
message s -> Getting Text s Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text s Text
forall (f :: * -> *) s a.
(Functor f, HasField s "type'" a) =>
LensLike' f s a
T.type'
      }

instance HasCodec TypedMessage where
  encode :: TypedMessage -> ByteString
encode = TypedMessage -> ByteString
forall msg. Message msg => msg -> ByteString
P.encodeMessage (TypedMessage -> ByteString)
-> (TypedMessage -> TypedMessage) -> TypedMessage -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting TypedMessage TypedMessage TypedMessage
-> TypedMessage -> TypedMessage
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TypedMessage TypedMessage TypedMessage
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
  decode :: ByteString -> Either Text TypedMessage
decode = (String -> Text)
-> (TypedMessage -> TypedMessage)
-> Either String TypedMessage
-> Either Text TypedMessage
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Getting TypedMessage TypedMessage TypedMessage
-> TypedMessage -> TypedMessage
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting TypedMessage TypedMessage TypedMessage
 -> TypedMessage -> TypedMessage)
-> Getting TypedMessage TypedMessage TypedMessage
-> TypedMessage
-> TypedMessage
forall a b. (a -> b) -> a -> b
$ AnIso TypedMessage TypedMessage TypedMessage TypedMessage
-> Iso TypedMessage TypedMessage TypedMessage TypedMessage
forall s t a b. AnIso s t a b -> Iso b a t s
from AnIso TypedMessage TypedMessage TypedMessage TypedMessage
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped') (Either String TypedMessage -> Either Text TypedMessage)
-> (ByteString -> Either String TypedMessage)
-> ByteString
-> Either Text TypedMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String TypedMessage
forall msg. Message msg => ByteString -> Either String msg
P.decodeMessage

-- | This is a general error type, primarily accomodating protobuf messages being parsed
-- | by either the [proto3-wire](https://hackage.haskell.org/package/proto3-wire)
-- | or the [proto-lens](https://hackage.haskell.org/package/proto-lens) libraries.
data MessageParseError =
    -- | A 'WireTypeError' occurs when the type of the data in the protobuf
    -- binary format does not match the type encountered by the parser.
    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 MessageParseError)
    -- | Unknown or unstructured parsing error.
  | OtherParseError Text

-- | Useful for returning in error logs or console logging.
formatMessageParseError
  :: MessageParseError
  -> Text
formatMessageParseError :: MessageParseError -> Text
formatMessageParseError = Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text)
-> (MessageParseError -> Text) -> MessageParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageParseError -> Text
go
  where
    go :: MessageParseError -> Text
go err :: MessageParseError
err =
      let (context :: Text
context,msg :: Text
msg) = case MessageParseError
err of
             WireTypeError txt :: Text
txt -> ("Wire Type Error", Text
txt)
             BinaryError txt :: Text
txt -> ("Binary Error", Text
txt)
             EmbeddedError txt :: Text
txt err' :: Maybe MessageParseError
err' -> ("Embedded Error", Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ". " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
-> (MessageParseError -> Text) -> Maybe MessageParseError -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" MessageParseError -> Text
go Maybe MessageParseError
err')
             OtherParseError txt :: Text
txt -> ("Other Error", Text
txt)
      in "Parse Error [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

-- Used to facilitate writing 'HasCodec' instances for protobuf messages that use
-- the proto3-suite library.
coerceProto3Error
  :: Wire.ParseError
  -> MessageParseError
coerceProto3Error :: ParseError -> MessageParseError
coerceProto3Error = \case
  Wire.WireTypeError txt :: Text
txt -> Text -> MessageParseError
WireTypeError (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
txt)
  Wire.BinaryError txt :: Text
txt -> Text -> MessageParseError
BinaryError (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
txt)
  Wire.EmbeddedError txt :: Text
txt merr :: Maybe ParseError
merr -> Text -> Maybe MessageParseError -> MessageParseError
EmbeddedError (Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs Text
txt) (ParseError -> MessageParseError
coerceProto3Error (ParseError -> MessageParseError)
-> Maybe ParseError -> Maybe MessageParseError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParseError
merr)

-- Used to facilitate writing 'HasCodec' instances for protobuf messages that use
-- the proto-lens library.
coerceProtoLensError
  :: String
  -> MessageParseError
coerceProtoLensError :: String -> MessageParseError
coerceProtoLensError = Text -> MessageParseError
OtherParseError (Text -> MessageParseError)
-> (String -> Text) -> String -> MessageParseError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs

-- | Used during message validation to indicate that although the message has parsed
-- | correctly, it fails certain sanity checks.
data MessageSemanticError =
    -- | Used to indicate that the message signer does not have the authority to send
    -- | this message.
    PermissionError Text
    -- | Used to indicate that a field isn't valid, e.g. enforces non-negative quantities
    -- | or nonempty lists.
  | InvalidFieldError Text
    -- Catchall for other erors
  | OtherSemanticError Text

formatMessageSemanticError
  :: MessageSemanticError
  -> Text
formatMessageSemanticError :: MessageSemanticError -> Text
formatMessageSemanticError err :: MessageSemanticError
err =
    let (context :: Text
context, msg :: Text
msg) = case MessageSemanticError
err of
          PermissionError m :: Text
m    -> ("Permission Error", Text
m)
          InvalidFieldError m :: Text
m  -> ("Invalid Field Error", Text
m)
          OtherSemanticError m :: Text
m -> ("Other Error", Text
m)
    in "Semantic Error [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

class ValidateMessage msg where
  validateMessage :: Msg msg -> V.Validation [MessageSemanticError] ()

nonEmptyCheck
  :: Eq a
  => Monoid a
  => Text
  -> a
  -> V.Validation [MessageSemanticError] ()
nonEmptyCheck :: Text -> a -> Validation [MessageSemanticError] ()
nonEmptyCheck fieldName :: Text
fieldName x :: a
x
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall a. Monoid a => a
mempty = Tagged [MessageSemanticError] (Identity [MessageSemanticError])
-> Tagged
     (Validation [MessageSemanticError] ())
     (Identity (Validation [MessageSemanticError] ()))
forall (f :: * -> * -> *) e1 a e2.
Validate f =>
Prism (f e1 a) (f e2 a) e1 e2
V._Failure (Tagged [MessageSemanticError] (Identity [MessageSemanticError])
 -> Tagged
      (Validation [MessageSemanticError] ())
      (Identity (Validation [MessageSemanticError] ())))
-> [MessageSemanticError] -> Validation [MessageSemanticError] ()
forall t b. AReview t b -> b -> t
# [Text -> MessageSemanticError
InvalidFieldError (Text -> MessageSemanticError) -> Text -> MessageSemanticError
forall a b. (a -> b) -> a -> b
$ Text
fieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " must be nonempty."]
  | Bool
otherwise = () -> Validation [MessageSemanticError] ()
forall err a. a -> Validation err a
V.Success ()

isAuthorCheck
  :: Text
  -> Msg msg
  -> (msg -> Address)
  -> V.Validation [MessageSemanticError] ()
isAuthorCheck :: Text
-> Msg msg
-> (msg -> Address)
-> Validation [MessageSemanticError] ()
isAuthorCheck fieldName :: Text
fieldName Msg{Address
msgAuthor :: Address
msgAuthor :: forall msg. Msg msg -> Address
msgAuthor, msg
msgData :: msg
msgData :: forall msg. Msg msg -> msg
msgData} getAuthor :: msg -> Address
getAuthor
  | msg -> Address
getAuthor msg
msgData Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
/= Address
msgAuthor = Tagged [MessageSemanticError] (Identity [MessageSemanticError])
-> Tagged
     (Validation [MessageSemanticError] ())
     (Identity (Validation [MessageSemanticError] ()))
forall (f :: * -> * -> *) e1 a e2.
Validate f =>
Prism (f e1 a) (f e2 a) e1 e2
V._Failure (Tagged [MessageSemanticError] (Identity [MessageSemanticError])
 -> Tagged
      (Validation [MessageSemanticError] ())
      (Identity (Validation [MessageSemanticError] ())))
-> [MessageSemanticError] -> Validation [MessageSemanticError] ()
forall t b. AReview t b -> b -> t
# [Text -> MessageSemanticError
PermissionError (Text -> MessageSemanticError) -> Text -> MessageSemanticError
forall a b. (a -> b) -> a -> b
$ Text
fieldName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " must be message author."]
  | Bool
otherwise = () -> Validation [MessageSemanticError] ()
forall err a. a -> Validation err a
V.Success ()