{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Api.Internal.Serialise.Cbor.Canonical
  ( canonicaliseCborBs
  , canonicaliseTerm
  )
where

import Cardano.Api.Internal.HasTypeProxy
import Cardano.Api.Internal.Serialise.Cbor

import Cardano.Binary (DecoderError (..))

import Codec.CBOR.Read (deserialiseFromBytes)
import Codec.CBOR.Term
  ( Term (..)
  , decodeTerm
  , encodeTerm
  )
import Codec.CBOR.Write (toBuilder)
import Control.Monad
import Control.Monad.Except
import Data.Bifunctor (first)
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as BSB
import Data.ByteString.Lazy qualified as LBS
import Data.List (sortBy)
import Data.Tuple.Extra (both)

-- | This function implements CBOR canonicalisation (RFC 7049):
--
-- * Map keys are sorted lexicographically
-- * Indefinite-length maps/lists are converted to finite-length maps/lists
-- * The representation of the CBOR major types is as small as possible (provided by "cborg" package)
--
-- This function implements only CBOR canonicalisation from CIP-21. Other requirements from CIP-21 are not implemented.
--
-- 1. CBOR RFC 7049, Canonicalisation description: https://datatracker.ietf.org/doc/html/rfc7049#section-3.9
-- 2. CIP-21: https://github.com/cardano-foundation/CIPs/blob/master/CIP-0021/README.md#canonical-cbor-serialization-format
canonicaliseCborBs :: BS.ByteString -> Either DecoderError BS.ByteString
canonicaliseCborBs :: ByteString -> Either DecoderError ByteString
canonicaliseCborBs ByteString
originalCborBytes = Term -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR (Term -> ByteString) -> (Term -> Term) -> Term -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
canonicaliseTerm (Term -> ByteString)
-> Either DecoderError Term -> Either DecoderError ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AsType Term -> ByteString -> Either DecoderError Term
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR AsType Term
AsTerm ByteString
originalCborBytes

decodeTermFromBs
  :: LBS.ByteString
  -> Either DecoderError Term
decodeTermFromBs :: ByteString -> Either DecoderError Term
decodeTermFromBs ByteString
input = do
  (ByteString
leftover, Term
result) <-
    (DeserialiseFailure -> DecoderError)
-> Either DeserialiseFailure (ByteString, Term)
-> Either DecoderError (ByteString, Term)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> DeserialiseFailure -> DecoderError
DecoderErrorDeserialiseFailure Text
"Cannot decode Term") (Either DeserialiseFailure (ByteString, Term)
 -> Either DecoderError (ByteString, Term))
-> Either DeserialiseFailure (ByteString, Term)
-> Either DecoderError (ByteString, Term)
forall a b. (a -> b) -> a -> b
$
      (forall s. Decoder s Term)
-> ByteString -> Either DeserialiseFailure (ByteString, Term)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes Decoder s Term
forall s. Decoder s Term
decodeTerm ByteString
input
  Bool -> Either DecoderError () -> Either DecoderError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
LBS.null ByteString
leftover) (Either DecoderError () -> Either DecoderError ())
-> Either DecoderError () -> Either DecoderError ()
forall a b. (a -> b) -> a -> b
$ do
    DecoderError -> Either DecoderError ()
forall a. DecoderError -> Either DecoderError a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DecoderError -> Either DecoderError ())
-> DecoderError -> Either DecoderError ()
forall a b. (a -> b) -> a -> b
$
      Text -> ByteString -> DecoderError
DecoderErrorLeftover Text
"Invalid CBOR: some bytes were not consumed" (ByteString -> ByteString
LBS.toStrict ByteString
leftover)
  Term -> Either DecoderError Term
forall a. a -> Either DecoderError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
result

-- | This function implements CBOR canonicalisation at the Term level:
--
-- * Map keys are sorted lexicographically
-- * Indefinite-length maps/lists are converted to finite-length maps/lists
canonicaliseTerm :: Term -> Term
canonicaliseTerm :: Term -> Term
canonicaliseTerm = \case
  (TMap [(Term, Term)]
termPairs) ->
    [(Term, Term)] -> Term
TMap ([(Term, Term)] -> Term)
-> ([(Term, Term)] -> [(Term, Term)]) -> [(Term, Term)] -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Term, Term) -> (Term, Term) -> Ordering)
-> [(Term, Term)] -> [(Term, Term)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Term, Term) -> (Term, Term) -> Ordering
forall a. (Term, a) -> (Term, a) -> Ordering
compareKeyTerms ([(Term, Term)] -> Term) -> [(Term, Term)] -> Term
forall a b. (a -> b) -> a -> b
$ ((Term, Term) -> (Term, Term)) -> [(Term, Term)] -> [(Term, Term)]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> (Term, Term) -> (Term, Term)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Term -> Term
canonicaliseTerm) [(Term, Term)]
termPairs
  (TMapI [(Term, Term)]
termPairs) ->
    [(Term, Term)] -> Term
TMap ([(Term, Term)] -> Term)
-> ([(Term, Term)] -> [(Term, Term)]) -> [(Term, Term)] -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Term, Term) -> (Term, Term) -> Ordering)
-> [(Term, Term)] -> [(Term, Term)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Term, Term) -> (Term, Term) -> Ordering
forall a. (Term, a) -> (Term, a) -> Ordering
compareKeyTerms ([(Term, Term)] -> Term) -> [(Term, Term)] -> Term
forall a b. (a -> b) -> a -> b
$ ((Term, Term) -> (Term, Term)) -> [(Term, Term)] -> [(Term, Term)]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> (Term, Term) -> (Term, Term)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Term -> Term
canonicaliseTerm) [(Term, Term)]
termPairs
  (TTagged Word64
tag Term
term) ->
    Word64 -> Term -> Term
TTagged Word64
tag (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Term
canonicaliseTerm Term
term
  (TListI [Term]
terms) ->
    [Term] -> Term
TList [Term]
terms
  Term
term -> Term
term

-- | Implements sorting of CBOR terms for canonicalisation. CBOR terms are compared by lexical order of their
-- bytes representation. We are only sorting the keys of the map here.
-- See: https://datatracker.ietf.org/doc/html/rfc7049#section-3.9
compareKeyTerms
  :: (Term, a)
  -- ^ (key, value) from a map
  -> (Term, a)
  -> Ordering
compareKeyTerms :: forall a. (Term, a) -> (Term, a) -> Ordering
compareKeyTerms (Term
t1, a
_) (Term
t2, a
_) = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Term -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Term
t1) (Term -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Term
t2)

instance HasTypeProxy Term where
  data AsType Term = AsTerm
  proxyToAsType :: Proxy Term -> AsType Term
proxyToAsType Proxy Term
_ = AsType Term
AsTerm

instance SerialiseAsCBOR Term where
  serialiseToCBOR :: Term -> ByteString
serialiseToCBOR = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Term -> ByteString) -> Term -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString (Builder -> ByteString) -> (Term -> Builder) -> Term -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> Builder
toBuilder (Encoding -> Builder) -> (Term -> Encoding) -> Term -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Encoding
encodeTerm
  deserialiseFromCBOR :: AsType Term -> ByteString -> Either DecoderError Term
deserialiseFromCBOR AsType Term
_proxy = ByteString -> Either DecoderError Term
decodeTermFromBs (ByteString -> Either DecoderError Term)
-> (ByteString -> ByteString)
-> ByteString
-> Either DecoderError Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict