Objects.hs

-- | Module      : IPLD.DagCBOR.Decoder.Objects
--   Description : Decodes CBOR objects from binary into the IPLD data model
--   Copyright   : Zoey McBride (c) 2026
--   License     : AGPL-3.0-or-later
--   Maintainer  : zoeymcbride@mailbox.org
--   Stability   : experimental
module IPLD.DagCBOR.Decoder.Objects
  ( -- * Instances of major-type data decoded from DAG-CBOR
    Object (..),
    decodeMajorType,
    decodeSupplemental,
    decodeObject,

    -- * Recursively defines object collections for CBOR
    MapData,
    ListData,
  )
where

import Control.DeepSeq (NFData (..), force)
import Control.Parallel.Strategies (parBuffer, rdeepseq, using)
import Data.Array.IArray qualified as Array
import Data.Bifunctor (Bifunctor (first))
import Data.Text (Text)
import Data.XCodec.BinaryTranscoder (BinaryTranscoder)
import Data.XCodec.BinaryTranscoder qualified as BXC
import IPLD.DM qualified as DM
import IPLD.DagCBOR.Decoder.Arguments
import IPLD.DagCBOR.Decoder.Errors
import IPLD.DagCBOR.Decoder.MajorTypes
import IPLD.DagCBOR.Decoder.Supplemental
import MultiFormats.CID (CID)

-- | Stores the data gotten from each major-type
data Object
  = -- | Instance of a CBOR positive integer.
    ObjectPositive IntData
  | -- | Instance of a CBOR negative integer.
    ObjectNegative IntData
  | -- | Instance of a CBOR bytestring.
    ObjectBytes DM.BytesData
  | -- | Instance of a CBOR UTF-8 string.
    ObjectUTF8 Text
  | -- | Instance of a valid IPLD CBOR list object.
    ObjectList ListData
  | -- | Instance of a valid IPLD CBOR map object.
    ObjectMap MapData
  | -- | Instance of a CID following its CBOR tag.
    ObjectTag CID
  | -- | Instance of simple types (null, bool, float).
    ObjectSimple SimpleData
  deriving (Show, Eq)

-- | Resolves the supplemental data from a major type.
instance (BinaryTranscoder bxc) => Supplemental MajorType Object bxc where
  decodeSup arg =
    case arg of
      TypePositive intrule -> mk ObjectPositive intrule
      TypeNegative intrule -> mk ObjectNegative intrule
      TypeBytes bytesrule -> mk ObjectBytes bytesrule
      TypeUTF8 utf8rule -> mk ObjectUTF8 utf8rule
      TypeList listrule -> mk ObjectList listrule
      TypeMap maprule -> mk ObjectMap maprule
      TypeTag tagrule -> mk ObjectTag tagrule
      TypeSimple simplerule -> mk ObjectSimple simplerule
    where
      -- Creates the DecoderMethod that reads the object using the given rule
      {-# INLINE mk #-}
      mk constructor rule =
        pure $ \bytes -> do
          sup <- decodeSup rule
          Result supdata rest <- sup bytes
          pure $ Result (constructor supdata) rest

-- | Translates the CBOR MajorObject into the IPLD data model.
{-# INLINE objectNode #-}
objectNode :: Object -> DM.Node
objectNode obj =
  -- Strictly evaluate the entire converted object
  force convObject
  where
    -- Points to the conversion of the object into a DM.Node
    {-# NOINLINE convObject #-}
    convObject =
      case obj of
        ObjectSimple NullData -> DM.NullKind
        ObjectSimple (BoolData bool) -> DM.BoolKind bool
        ObjectSimple (FloatData float) -> DM.FloatKind float
        ObjectBytes bytes -> DM.BytesKind bytes
        ObjectUTF8 text -> DM.StringKind text
        ObjectTag cid -> DM.ResourceKind cid
        ObjectList (ListData listdata) -> DM.ListKind listdata
        ObjectMap (MapData mapdata) -> DM.MapKind mapdata
        -- Convert the raw intdata into Haskell Integer (including zero)
        ObjectPositive intdata -> DM.IntKind (fromIntegral intdata)
        -- Adjust negative values for extra digit from not having zero
        ObjectNegative intdata -> DM.IntKind (-(fromIntegral intdata) - 1)

-- | Decodes the CBOR major-type for the first transcoder byte and keeps it in
-- place.
decodeMajorType :: (BinaryTranscoder bxc) => DecoderMethod MajorType bxc
decodeMajorType bytes = do
  Result top _ <- extractByte bytes
  mt <- decodeArg top
  Right $ Result mt bytes

-- | Decodes a major-type's supplemental data from the CBOR object binary and
-- removes it.
decodeSupplemental ::
  (BinaryTranscoder bxc) =>
  MajorType ->
  DecoderMethod Object bxc
decodeSupplemental mt bytes = do
  sup <- decodeSup mt
  sup bytes

-- | Decodes the MajorType and it's Supplemental data from the transcoder and
-- removes both.
decodeObject :: (BinaryTranscoder bxc) => DecoderMethod DM.Node bxc
decodeObject bytes = do
  Result mt _ <- decodeMajorType bytes
  Result _ inner <- extractByte bytes
  first objectNode <$> decodeSupplemental mt inner

-- | Decodes list/map subobjects in parallel using the given decoder function.
decodeSubObjects ::
  (Monoid x, NFData y) =>
  IntData ->
  Int ->
  (x -> Okay y) ->
  [x] ->
  Okay [y]
decodeSubObjects size count decoder bxcs
  -- Run the subdecoders in parallel, and join the objects in sequence on
  -- success, and fully evaluates the subobject w/ deepseq.
  | mtenabled = sequence (mapdecoder `using` parBuffer numsparks rdeepseq)
  -- Otherwise, use single-threading.
  | otherwise =  sequence mapdecoder
  where
    -- Minimum #items and #bytes to qualify for requesting spark threads
    mtenabled = count > 1 && (count > minsparks || size > 4096)
    -- Sets the #sparks, which becomes an enqueued thread to run or become GC'd
    numsparks = max minsparks (min maxsparks count)
    -- Maps the decoder onto the list of binary CBOR objects
    mapdecoder = map decoder bxcs
    -- Maximum #sparks to request from the RTS
    maxsparks = 128
    -- Minimum #sparks to request from the RTS
    minsparks = 16

-- | Provides ListData from DM for DAG-CBOR list object.
newtype ListData = ListData (DM.ListData DM.Node) deriving (Show, Eq)

-- | Implements reading list objects from CBOR.
instance (BinaryTranscoder bxc) => Supplemental Collection ListData bxc where
  decodeSup arg = do
    case arg of
      CollectionsIndefinite -> Left Indefinite
      CollectionsLength ints ->
        Right $ \bytes -> do
          -- Read the list of binary CBOR objects and decode them
          sup <- decodeSup arg :: Okay (DecoderMethod (ListObj bxc) bxc)
          Result (size, chunks) following <- sup bytes
          -- Read the #elements in the list from the top of the bytes
          Result elems _ <- extractIntData ints bytes
          ielems <- downcastIntData elems
          -- Decode the subobjects of the list
          objs <- decodeSubObjects size ielems decodeElem chunks
          let listarray = Array.listArray (0, ielems - 1) objs
          Right $ Result (ListData listarray) following
    where
      -- Decodes single CBOR list element from binary
      {-# NOINLINE decodeElem #-}
      decodeElem bin = do
        Result obj after <- decodeObject bin
        if not (BXC.null after)
          then Left Fragmented
          else return obj

-- | Provides ListData from DM for DAG-CBOR list object.
newtype MapData = MapData (DM.MapData DM.Node DM.Node) deriving (Show, Eq)

-- | Implements reading map objects from CBOR.
instance (BinaryTranscoder bxc) => Supplemental Collection MapData bxc where
  decodeSup arg = do
    case arg of
      CollectionsIndefinite -> Left Indefinite
      CollectionsLength ints ->
        Right $ \bytes -> do
          -- Read the map of binary CBOR objects pairs and decode them
          sup <- decodeSup arg :: Okay (DecoderMethod (MapObj bxc) bxc)
          Result (size, chunks) following <- sup bytes
          -- Read the #elements in the list from the top of the bytes
          Result pairs _ <- extractIntData ints bytes
          ipairs <- downcastIntData pairs
          -- Decode the subobjects of the map
          objs <- decodeSubObjects size ipairs decodePair chunks
          let maparray = Array.listArray (0, ipairs - 1) objs
          Right $ Result (MapData maparray) following
    where
      -- Decodes single CBOR map pair from binary tuple
      {-# NOINLINE decodePair #-}
      decodePair (bin1, bin2) = do
        -- Read the key and value binary objects
        Result key afterkey <- decodeObject bin1
        Result val afterval <- decodeObject bin2
        -- Verify parsing the map succeeded
        case (key, val) of
          ypair
            | not (BXC.null afterkey && BXC.null afterval) -> Left Fragmented
            | not (isKeyValidDAGCBOR key) -> Left NotStringKey
            | otherwise -> Right ypair
      -- Gives true if the key object for the map is a string type
      {-# INLINE isKeyValidDAGCBOR #-}
      isKeyValidDAGCBOR (DM.StringKind _) = True
      isKeyValidDAGCBOR _OtherKinds = False