{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -- | -- Module : Codec.CBOR.Term -- Copyright : (c) Duncan Coutts 2015-2017 -- License : BSD3-style (see LICENSE.txt) -- -- Maintainer : duncan@community.haskell.org -- Stability : experimental -- Portability : non-portable (GHC extensions) -- -- This module provides an interface for decoding and encoding arbitrary -- CBOR values (ones that, for example, may not have been generated by this -- library). -- -- Using 'decodeTerm', you can decode an arbitrary CBOR value given to you -- into a 'Term', which represents a CBOR value as an AST. -- -- Similarly, if you wanted to encode some value into a CBOR value directly, -- you can wrap it in a 'Term' constructor and use 'encodeTerm'. This -- would be useful, as an example, if you needed to serialise some value into -- a CBOR term that is not compatible with that types 'Serialise' instance. -- -- Because this interface gives you the ability to decode or encode any -- arbitrary CBOR term, it can also be seen as an alternative interface to the -- 'Codec.CBOR.Encoding' and -- 'Codec.CBOR.Decoding' modules. -- module Codec.CBOR.Term ( Term(..) -- :: * , encodeTerm -- :: Term -> Encoding , decodeTerm -- :: Decoder Term ) where #include "cbor.h" import Codec.CBOR.Encoding hiding (Tokens(..)) import Codec.CBOR.Decoding import Data.Word import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Monoid import Control.Applicative import Prelude hiding (encodeFloat, decodeFloat) -------------------------------------------------------------------------------- -- Types -- | A general CBOR term, which can be used to serialise or deserialise -- arbitrary CBOR terms for interoperability or debugging. This type is -- essentially a direct reflection of the CBOR abstract syntax tree as a -- Haskell data type. -- -- The 'Term' type also comes with a 'Serialise' instance, so you can -- easily use @'decode' :: 'Decoder' 'Term'@ to directly decode any arbitrary -- CBOR value into Haskell with ease, and likewise with 'encode'. -- -- @since 0.2.0.0 data Term = TInt {-# UNPACK #-} !Int | TInteger !Integer | TBytes !BS.ByteString | TBytesI !LBS.ByteString | TString !T.Text | TStringI !LT.Text | TList ![Term] | TListI ![Term] | TMap ![(Term, Term)] | TMapI ![(Term, Term)] | TTagged {-# UNPACK #-} !Word64 !Term | TBool !Bool | TNull | TSimple {-# UNPACK #-} !Word8 | THalf {-# UNPACK #-} !Float | TFloat {-# UNPACK #-} !Float | TDouble {-# UNPACK #-} !Double deriving (Eq, Ord, Show, Read) -------------------------------------------------------------------------------- -- Main API -- | Encode an arbitrary 'Term' into an 'Encoding' for later serialization. -- -- @since 0.2.0.0 encodeTerm :: Term -> Encoding encodeTerm (TInt n) = encodeInt n encodeTerm (TInteger n) = encodeInteger n encodeTerm (TBytes bs) = encodeBytes bs encodeTerm (TString st) = encodeString st encodeTerm (TBytesI bss) = encodeBytesIndef <> mconcat [ encodeBytes bs | bs <- LBS.toChunks bss ] <> encodeBreak encodeTerm (TStringI sts) = encodeStringIndef <> mconcat [ encodeString str | str <- LT.toChunks sts ] <> encodeBreak encodeTerm (TList ts) = encodeListLen (fromIntegral $ length ts) <> mconcat [ encodeTerm t | t <- ts ] encodeTerm (TListI ts) = encodeListLenIndef <> mconcat [ encodeTerm t | t <- ts ] <> encodeBreak encodeTerm (TMap ts) = encodeMapLen (fromIntegral $ length ts) <> mconcat [ encodeTerm t <> encodeTerm t' | (t, t') <- ts ] encodeTerm (TMapI ts) = encodeMapLenIndef <> mconcat [ encodeTerm t <> encodeTerm t' | (t, t') <- ts ] <> encodeBreak encodeTerm (TTagged w t) = encodeTag64 w <> encodeTerm t encodeTerm (TBool b) = encodeBool b encodeTerm TNull = encodeNull encodeTerm (TSimple w) = encodeSimple w encodeTerm (THalf f) = encodeFloat16 f encodeTerm (TFloat f) = encodeFloat f encodeTerm (TDouble f) = encodeDouble f -- | Decode some arbitrary CBOR value into a 'Term'. -- -- @since 0.2.0.0 decodeTerm :: Decoder s Term decodeTerm = do tkty <- peekTokenType case tkty of TypeUInt -> do w <- decodeWord return $! fromWord w where fromWord :: Word -> Term fromWord w | w <= fromIntegral (maxBound :: Int) = TInt (fromIntegral w) | otherwise = TInteger (fromIntegral w) TypeUInt64 -> do w <- decodeWord64 return $! fromWord64 w where fromWord64 w | w <= fromIntegral (maxBound :: Int) = TInt (fromIntegral w) | otherwise = TInteger (fromIntegral w) TypeNInt -> do w <- decodeNegWord return $! fromNegWord w where fromNegWord w | w <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral w) | otherwise = TInteger (-1 - fromIntegral w) TypeNInt64 -> do w <- decodeNegWord64 return $! fromNegWord64 w where fromNegWord64 w | w <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral w) | otherwise = TInteger (-1 - fromIntegral w) TypeInteger -> do !x <- decodeInteger return (TInteger x) TypeFloat16 -> do !x <- decodeFloat return (THalf x) TypeFloat32 -> do !x <- decodeFloat return (TFloat x) TypeFloat64 -> do !x <- decodeDouble return (TDouble x) TypeBytes -> do !x <- decodeBytes return (TBytes x) TypeBytesIndef -> decodeBytesIndef >> decodeBytesIndefLen [] TypeString -> do !x <- decodeString return (TString x) TypeStringIndef -> decodeStringIndef >> decodeStringIndefLen [] TypeListLen -> decodeListLen >>= flip decodeListN [] TypeListLen64 -> decodeListLen >>= flip decodeListN [] TypeListLenIndef -> decodeListLenIndef >> decodeListIndefLen [] TypeMapLen -> decodeMapLen >>= flip decodeMapN [] TypeMapLen64 -> decodeMapLen >>= flip decodeMapN [] TypeMapLenIndef -> decodeMapLenIndef >> decodeMapIndefLen [] TypeTag -> do !x <- decodeTag64 !y <- decodeTerm return (TTagged x y) TypeTag64 -> do !x <- decodeTag64 !y <- decodeTerm return (TTagged x y) TypeBool -> do !x <- decodeBool return (TBool x) TypeNull -> TNull <$ decodeNull TypeSimple -> do !x <- decodeSimple return (TSimple x) TypeBreak -> fail "unexpected break" TypeInvalid -> fail "invalid token encoding" -------------------------------------------------------------------------------- -- Internal utilities decodeBytesIndefLen :: [BS.ByteString] -> Decoder s Term decodeBytesIndefLen acc = do stop <- decodeBreakOr if stop then return $! TBytesI (LBS.fromChunks (reverse acc)) else do !bs <- decodeBytes decodeBytesIndefLen (bs : acc) decodeStringIndefLen :: [T.Text] -> Decoder s Term decodeStringIndefLen acc = do stop <- decodeBreakOr if stop then return $! TStringI (LT.fromChunks (reverse acc)) else do !str <- decodeString decodeStringIndefLen (str : acc) decodeListN :: Int -> [Term] -> Decoder s Term decodeListN !n acc = case n of 0 -> return $! TList (reverse acc) _ -> do !t <- decodeTerm decodeListN (n-1) (t : acc) decodeListIndefLen :: [Term] -> Decoder s Term decodeListIndefLen acc = do stop <- decodeBreakOr if stop then return $! TListI (reverse acc) else do !tm <- decodeTerm decodeListIndefLen (tm : acc) decodeMapN :: Int -> [(Term, Term)] -> Decoder s Term decodeMapN !n acc = case n of 0 -> return $! TMap (reverse acc) _ -> do !tm <- decodeTerm !tm' <- decodeTerm decodeMapN (n-1) ((tm, tm') : acc) decodeMapIndefLen :: [(Term, Term)] -> Decoder s Term decodeMapIndefLen acc = do stop <- decodeBreakOr if stop then return $! TMapI (reverse acc) else do !tm <- decodeTerm !tm' <- decodeTerm decodeMapIndefLen ((tm, tm') : acc)