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

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

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

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 by RFC 7049 §3.9 canonical order (shorter keys first, then 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
  (leftover, 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
  unless (LBS.null leftover) $ do
    throwError $
      DecoderErrorLeftover "Invalid CBOR: some bytes were not consumed" (LBS.toStrict leftover)
  pure result

-- | This function implements CBOR canonicalisation at the Term level:
--
-- * Map keys are sorted by RFC 7049 §3.9 canonical order (shorter keys first, then 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] -> Term) -> [Term] -> Term
forall a b. (a -> b) -> a -> b
$ (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Term
canonicaliseTerm [Term]
terms
  (TList [Term]
terms) ->
    [Term] -> Term
TList ([Term] -> Term) -> [Term] -> Term
forall a b. (a -> b) -> a -> b
$ (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Term
canonicaliseTerm [Term]
terms
  Term
term -> Term
term

-- | RFC 7049 §3.9 canonical ordering of map keys: "If two keys have different lengths,
-- the shorter one sorts earlier; if two keys have the same length, the one with the
-- lower value in (byte-wise) lexical order sorts earlier."
-- 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
_) =
  let b1 :: ByteString
b1 = Term -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Term
t1
      b2 :: ByteString
b2 = Term -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Term
t2
   in Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ByteString -> Int
BS.length ByteString
b1) (ByteString -> Int
BS.length ByteString
b2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteString
b1 ByteString
b2

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