{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RecordWildCards #-}

-- | Various helper functions for CBOR validation against supported CDDL specifications.
module Cardano.Ledger.CanonicalState.CDDL.Validate (
  validateBytesAgainst,
  invalidSpecs,
  validSpecs,
) where

import Cardano.Ledger.CanonicalState.Namespace.CDDL
import Cardano.SCLS.NamespaceSymbol (
  KnownSpec (namespaceSpec),
  SomeNamespaceSymbol (SomeNamespaceSymbol),
 )
import Codec.CBOR.Cuddle.CBOR.Validator (validateCBOR)
import Codec.CBOR.Cuddle.CBOR.Validator.Trace (Evidenced, ValidationTrace)
import Codec.CBOR.Cuddle.CDDL (Name (..))
import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..))
import Codec.CBOR.Cuddle.CDDL.Resolve (
  MonoReferenced,
  NameResolutionFailure,
  asMap,
  buildMonoCTree,
  buildRefCTree,
  buildResolvedCTree,
 )
import Codec.CBOR.Cuddle.Huddle (toCDDL)
import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (mapIndex), mapCDDLDropExt)
import Data.ByteString (ByteString)
import qualified Data.Map.Strict as Map
import Data.Text (Text)

-- | Pre-compiled CDDL specifications for all supported namespaces.
invalidSpecs :: Map.Map SomeNamespaceSymbol NameResolutionFailure
validSpecs :: Map.Map SomeNamespaceSymbol (CTreeRoot Codec.CBOR.Cuddle.CDDL.Resolve.MonoReferenced)
(Map SomeNamespaceSymbol NameResolutionFailure
invalidSpecs, Map SomeNamespaceSymbol (CTreeRoot MonoReferenced)
validSpecs) = (Huddle -> Either NameResolutionFailure (CTreeRoot MonoReferenced))
-> Map SomeNamespaceSymbol Huddle
-> (Map SomeNamespaceSymbol NameResolutionFailure,
    Map SomeNamespaceSymbol (CTreeRoot MonoReferenced))
forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
Map.mapEither
  do
    \Huddle
hddl -> do
      PartialCTreeRoot DistReferenced
-> Either NameResolutionFailure (CTreeRoot MonoReferenced)
buildMonoCTree (PartialCTreeRoot DistReferenced
 -> Either NameResolutionFailure (CTreeRoot MonoReferenced))
-> Either NameResolutionFailure (PartialCTreeRoot DistReferenced)
-> Either NameResolutionFailure (CTreeRoot MonoReferenced)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PartialCTreeRoot OrReferenced
-> Either NameResolutionFailure (PartialCTreeRoot DistReferenced)
buildResolvedCTree (CDDLMap -> PartialCTreeRoot OrReferenced
buildRefCTree (CDDLMap -> PartialCTreeRoot OrReferenced)
-> CDDLMap -> PartialCTreeRoot OrReferenced
forall a b. (a -> b) -> a -> b
$ CDDL CTreePhase -> CDDLMap
asMap (CDDL CTreePhase -> CDDLMap) -> CDDL CTreePhase -> CDDLMap
forall a b. (a -> b) -> a -> b
$ CDDL HuddleStage -> CDDL CTreePhase
forall i j.
(IndexMappable XXType2 i j, IndexMappable XTerm i j,
 IndexMappable XRule i j) =>
CDDL i -> CDDL j
mapCDDLDropExt (CDDL HuddleStage -> CDDL CTreePhase)
-> CDDL HuddleStage -> CDDL CTreePhase
forall a b. (a -> b) -> a -> b
$ Huddle -> CDDL HuddleStage
toCDDL Huddle
hddl)
  do namespacesM
  where
    namespacesM :: Map SomeNamespaceSymbol Huddle
namespacesM =
      [(SomeNamespaceSymbol, Huddle)] -> Map SomeNamespaceSymbol Huddle
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ ( SomeNamespaceSymbol
nsSym
          , Proxy ns -> Huddle
forall (ns :: Symbol) (proxy :: Symbol -> *).
KnownSpec ns =>
proxy ns -> Huddle
forall (proxy :: Symbol -> *). proxy ns -> Huddle
namespaceSpec Proxy ns
p
          )
        | nsSym :: SomeNamespaceSymbol
nsSym@(SomeNamespaceSymbol Proxy ns
p) <- [SomeNamespaceSymbol]
knownNamespaces
        ]

-- | Validate raw bytes against a rule in the namespace.
validateBytesAgainst :: ByteString -> Text -> Text -> Maybe (Evidenced ValidationTrace)
validateBytesAgainst :: ByteString -> Text -> Text -> Maybe (Evidenced ValidationTrace)
validateBytesAgainst ByteString
bytes Text
namespace Text
name = do
  cddl <- Text -> Maybe SomeNamespaceSymbol
namespaceSymbolFromText Text
namespace Maybe SomeNamespaceSymbol
-> (SomeNamespaceSymbol -> Maybe (CTreeRoot MonoReferenced))
-> Maybe (CTreeRoot MonoReferenced)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeNamespaceSymbol
 -> Map SomeNamespaceSymbol (CTreeRoot MonoReferenced)
 -> Maybe (CTreeRoot MonoReferenced))
-> Map SomeNamespaceSymbol (CTreeRoot MonoReferenced)
-> SomeNamespaceSymbol
-> Maybe (CTreeRoot MonoReferenced)
forall a b c. (a -> b -> c) -> b -> a -> c
flip SomeNamespaceSymbol
-> Map SomeNamespaceSymbol (CTreeRoot MonoReferenced)
-> Maybe (CTreeRoot MonoReferenced)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map SomeNamespaceSymbol (CTreeRoot MonoReferenced)
validSpecs
  case validateCBOR bytes (Name name) (mapIndex cddl) of
    Right Evidenced ValidationTrace
res -> Evidenced ValidationTrace -> Maybe (Evidenced ValidationTrace)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Evidenced ValidationTrace
res
    Left ValidateCBORError
_ -> Maybe (Evidenced ValidationTrace)
forall a. Maybe a
Nothing