cborg-0.2.2.0: src/Codec/CBOR/FlatTerm.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
-- |
-- Module : Codec.CBOR.FlatTerm
-- Copyright : (c) Duncan Coutts 2015-2017
-- License : BSD3-style (see LICENSE.txt)
--
-- Maintainer : duncan@community.haskell.org
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
-- A simpler form than CBOR for writing out 'Enc.Encoding' values that allows
-- easier verification and testing. While this library primarily focuses
-- on taking 'Enc.Encoding' values (independent of any underlying format)
-- and serializing them into CBOR format, this module offers an alternative
-- format called 'FlatTerm' for serializing 'Enc.Encoding' values.
--
-- The 'FlatTerm' form is very simple and internally mirrors the original
-- 'Encoding' type very carefully. The intention here is that once you
-- have 'Enc.Encoding' and 'Dec.Decoding' values for your types, you can
-- round-trip values through 'FlatTerm' to catch bugs more easily and with
-- a smaller amount of code to look through.
--
-- For that reason, this module is primarily useful for client libraries,
-- and even then, only for their test suites to offer a simpler form for
-- doing encoding tests and catching problems in an encoder and decoder.
--
module Codec.CBOR.FlatTerm
( -- * Types
FlatTerm -- :: *
, TermToken(..) -- :: *
-- * Functions
, toFlatTerm -- :: Encoding -> FlatTerm
, fromFlatTerm -- :: Decoder s a -> FlatTerm -> Either String a
, validFlatTerm -- :: FlatTerm -> Bool
, decodeTermToken -- Decoder s TermToken
) where
#include "cbor.h"
import Codec.CBOR.Encoding (Encoding(..))
import qualified Codec.CBOR.Encoding as Enc
import Codec.CBOR.Decoding as Dec
import qualified Codec.CBOR.Read as Read
import qualified Codec.CBOR.ByteArray as BA
import qualified Codec.CBOR.ByteArray.Sliced as BAS
import Data.Int
#if defined(ARCH_32bit)
import GHC.Int (Int64(I64#))
import GHC.Word (Word64(W64#))
import GHC.Exts (Word64#, Int64#)
#endif
import GHC.Word (Word(W#), Word8(W8#))
import GHC.Exts (Int(I#), Int#, Word#, Float#, Double#)
import GHC.Float (Float(F#), Double(D#), float2Double)
import Data.Word
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Control.Monad.ST
import qualified Control.Monad.ST.Lazy as ST.Lazy
import Prelude hiding (encodeFloat, decodeFloat)
--------------------------------------------------------------------------------
-- | A \"flat\" representation of an 'Enc.Encoding' value,
-- useful for round-tripping and writing tests.
--
-- @since 0.2.0.0
type FlatTerm = [TermToken]
-- | A concrete encoding of 'Enc.Encoding' values, one
-- which mirrors the original 'Enc.Encoding' type closely.
--
-- @since 0.2.0.0
data TermToken
= TkInt {-# UNPACK #-} !Int
| TkInteger !Integer
| TkBytes {-# UNPACK #-} !ByteString
| TkBytesBegin
| TkString {-# UNPACK #-} !Text
| TkStringBegin
| TkListLen {-# UNPACK #-} !Word
| TkListBegin
| TkMapLen {-# UNPACK #-} !Word
| TkMapBegin
| TkBreak
| TkTag {-# UNPACK #-} !Word64
| TkBool !Bool
| TkNull
| TkSimple {-# UNPACK #-} !Word8
| TkFloat16 {-# UNPACK #-} !Float
| TkFloat32 {-# UNPACK #-} !Float
| TkFloat64 {-# UNPACK #-} !Double
deriving (Eq, Ord, Show)
--------------------------------------------------------------------------------
-- | Convert an arbitrary 'Enc.Encoding' into a 'FlatTerm'.
--
-- @since 0.2.0.0
toFlatTerm :: Encoding -- ^ The input 'Enc.Encoding'.
-> FlatTerm -- ^ The resulting 'FlatTerm'.
toFlatTerm (Encoding tb) = convFlatTerm (tb Enc.TkEnd)
convFlatTerm :: Enc.Tokens -> FlatTerm
convFlatTerm (Enc.TkWord w ts)
| w <= maxInt = TkInt (fromIntegral w) : convFlatTerm ts
| otherwise = TkInteger (fromIntegral w) : convFlatTerm ts
convFlatTerm (Enc.TkWord64 w ts)
| w <= maxInt = TkInt (fromIntegral w) : convFlatTerm ts
| otherwise = TkInteger (fromIntegral w) : convFlatTerm ts
convFlatTerm (Enc.TkInt n ts) = TkInt n : convFlatTerm ts
convFlatTerm (Enc.TkInt64 n ts)
| n <= maxInt && n >= minInt = TkInt (fromIntegral n) : convFlatTerm ts
| otherwise = TkInteger (fromIntegral n) : convFlatTerm ts
convFlatTerm (Enc.TkInteger n ts)
| n <= maxInt && n >= minInt = TkInt (fromIntegral n) : convFlatTerm ts
| otherwise = TkInteger n : convFlatTerm ts
convFlatTerm (Enc.TkBytes bs ts) = TkBytes bs : convFlatTerm ts
convFlatTerm (Enc.TkBytesBegin ts) = TkBytesBegin : convFlatTerm ts
convFlatTerm (Enc.TkByteArray a ts)
= TkBytes (BAS.toByteString a) : convFlatTerm ts
convFlatTerm (Enc.TkString st ts) = TkString st : convFlatTerm ts
convFlatTerm (Enc.TkStringBegin ts) = TkStringBegin : convFlatTerm ts
convFlatTerm (Enc.TkUtf8ByteArray a ts)
= TkString (TE.decodeUtf8 $ BAS.toByteString a) : convFlatTerm ts
convFlatTerm (Enc.TkListLen n ts) = TkListLen n : convFlatTerm ts
convFlatTerm (Enc.TkListBegin ts) = TkListBegin : convFlatTerm ts
convFlatTerm (Enc.TkMapLen n ts) = TkMapLen n : convFlatTerm ts
convFlatTerm (Enc.TkMapBegin ts) = TkMapBegin : convFlatTerm ts
convFlatTerm (Enc.TkTag n ts) = TkTag (fromIntegral n) : convFlatTerm ts
convFlatTerm (Enc.TkTag64 n ts) = TkTag n : convFlatTerm ts
convFlatTerm (Enc.TkBool b ts) = TkBool b : convFlatTerm ts
convFlatTerm (Enc.TkNull ts) = TkNull : convFlatTerm ts
convFlatTerm (Enc.TkUndef ts) = TkSimple 23 : convFlatTerm ts
convFlatTerm (Enc.TkSimple n ts) = TkSimple n : convFlatTerm ts
convFlatTerm (Enc.TkFloat16 f ts) = TkFloat16 f : convFlatTerm ts
convFlatTerm (Enc.TkFloat32 f ts) = TkFloat32 f : convFlatTerm ts
convFlatTerm (Enc.TkFloat64 f ts) = TkFloat64 f : convFlatTerm ts
convFlatTerm (Enc.TkBreak ts) = TkBreak : convFlatTerm ts
convFlatTerm (Enc.TkEncoded bs ts) = decodePreEncoded bs
++ convFlatTerm ts
convFlatTerm Enc.TkEnd = []
--------------------------------------------------------------------------------
decodePreEncoded :: BS.ByteString -> FlatTerm
decodePreEncoded bs0 =
ST.Lazy.runST (provideInput bs0)
where
provideInput :: BS.ByteString -> ST.Lazy.ST s FlatTerm
provideInput bs
| BS.null bs = return []
| otherwise = do
next <- ST.Lazy.strictToLazyST $ do
-- This will always be a 'Partial' here because decodeTermToken
-- always starts by requesting initial input. Only decoders that
-- fail or return a value without looking at their input can give
-- a different initial result.
Read.Partial k <- Read.deserialiseIncremental decodeTermToken
k (Just bs)
collectOutput next
collectOutput :: Read.IDecode s TermToken -> ST.Lazy.ST s FlatTerm
collectOutput (Read.Fail _ _ err) = fail $ "toFlatTerm: encodePreEncoded "
++ "used with invalid CBOR: "
++ show err
collectOutput (Read.Partial k) = ST.Lazy.strictToLazyST (k Nothing)
>>= collectOutput
collectOutput (Read.Done bs' _ x) = do xs <- provideInput bs'
return (x : xs)
decodeTermToken :: Decoder s TermToken
decodeTermToken = do
tkty <- peekTokenType
case tkty of
TypeUInt -> do w <- decodeWord
return $! fromWord w
where
fromWord :: Word -> TermToken
fromWord w
| w <= fromIntegral (maxBound :: Int)
= TkInt (fromIntegral w)
| otherwise = TkInteger (fromIntegral w)
TypeUInt64 -> do w <- decodeWord64
return $! fromWord64 w
where
fromWord64 w
| w <= fromIntegral (maxBound :: Int)
= TkInt (fromIntegral w)
| otherwise = TkInteger (fromIntegral w)
TypeNInt -> do w <- decodeNegWord
return $! fromNegWord w
where
fromNegWord w
| w <= fromIntegral (maxBound :: Int)
= TkInt (-1 - fromIntegral w)
| otherwise = TkInteger (-1 - fromIntegral w)
TypeNInt64 -> do w <- decodeNegWord64
return $! fromNegWord64 w
where
fromNegWord64 w
| w <= fromIntegral (maxBound :: Int)
= TkInt (-1 - fromIntegral w)
| otherwise = TkInteger (-1 - fromIntegral w)
TypeInteger -> do !x <- decodeInteger
return (TkInteger x)
TypeFloat16 -> do !x <- decodeFloat
return (TkFloat16 x)
TypeFloat32 -> do !x <- decodeFloat
return (TkFloat32 x)
TypeFloat64 -> do !x <- decodeDouble
return (TkFloat64 x)
TypeBytes -> do !x <- decodeBytes
return (TkBytes x)
TypeBytesIndef -> do decodeBytesIndef
return TkBytesBegin
TypeString -> do !x <- decodeString
return (TkString x)
TypeStringIndef -> do decodeStringIndef
return TkStringBegin
TypeListLen -> do !x <- decodeListLen
return $! TkListLen (fromIntegral x)
TypeListLen64 -> do !x <- decodeListLen
return $! TkListLen (fromIntegral x)
TypeListLenIndef -> do decodeListLenIndef
return TkListBegin
TypeMapLen -> do !x <- decodeMapLen
return $! TkMapLen (fromIntegral x)
TypeMapLen64 -> do !x <- decodeMapLen
return $! TkMapLen (fromIntegral x)
TypeMapLenIndef -> do decodeMapLenIndef
return TkMapBegin
TypeTag -> do !x <- decodeTag
return $! TkTag (fromIntegral x)
TypeTag64 -> do !x <- decodeTag
return $! TkTag (fromIntegral x)
TypeBool -> do !x <- decodeBool
return (TkBool x)
TypeNull -> do decodeNull
return TkNull
TypeSimple -> do !x <- decodeSimple
return (TkSimple x)
TypeBreak -> do _ <- decodeBreakOr
return TkBreak
TypeInvalid -> fail "invalid token encoding"
--------------------------------------------------------------------------------
-- | Given a 'Dec.Decoder', decode a 'FlatTerm' back into
-- an ordinary value, or return an error.
--
-- @since 0.2.0.0
fromFlatTerm :: (forall s. Decoder s a)
-- ^ A 'Dec.Decoder' for a serialised value.
-> FlatTerm -- ^ The serialised 'FlatTerm'.
-> Either String a -- ^ The deserialised value, or an error.
fromFlatTerm decoder ft =
runST (getDecodeAction decoder >>= go ft)
where
go :: FlatTerm -> DecodeAction s a -> ST s (Either String a)
go (TkInt n : ts) (ConsumeWord k)
| n >= 0 = k (unW# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord k)
| n >= 0 = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeWord8 k)
| n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord8 k)
| n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeWord16 k)
| n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord16 k)
| n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeWord32 k)
-- NOTE: we have to be very careful about this branch
-- on 32 bit machines, because maxBound :: Int < maxBound :: Word32
| intIsValidWord32 n = k (unW# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord32 k)
| n >= 0 && n <= maxWord32 = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeNegWord k)
| n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts
go (TkInteger n : ts) (ConsumeNegWord k)
| n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts
go (TkInt n : ts) (ConsumeInt k) = k (unI# n) >>= go ts
go (TkInteger n : ts) (ConsumeInt k)
| n <= maxInt = k (unI# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeInt8 k)
| n >= minInt8 && n <= maxInt8 = k (unI# n) >>= go ts
go (TkInteger n : ts) (ConsumeInt8 k)
| n >= minInt8 && n <= maxInt8 = k (unI# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeInt16 k)
| n >= minInt16 && n <= maxInt16 = k (unI# n) >>= go ts
go (TkInteger n : ts) (ConsumeInt16 k)
| n >= minInt16 && n <= maxInt16 = k (unI# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeInt32 k)
| n >= minInt32 && n <= maxInt32 = k (unI# n) >>= go ts
go (TkInteger n : ts) (ConsumeInt32 k)
| n >= minInt32 && n <= maxInt32 = k (unI# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeInteger k) = k (fromIntegral n) >>= go ts
go (TkInteger n : ts) (ConsumeInteger k) = k n >>= go ts
go (TkListLen n : ts) (ConsumeListLen k)
| n <= maxInt = k (unI# (fromIntegral n)) >>= go ts
go (TkMapLen n : ts) (ConsumeMapLen k)
| n <= maxInt = k (unI# (fromIntegral n)) >>= go ts
go (TkTag n : ts) (ConsumeTag k)
| n <= maxWord = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeWordCanonical k)
| n >= 0 = k (unW# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWordCanonical k)
| n >= 0 = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeWord8Canonical k)
| n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord8Canonical k)
| n >= 0 && n <= maxWord8 = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeWord16Canonical k)
| n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord16Canonical k)
| n >= 0 && n <= maxWord16 = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeWord32Canonical k)
-- NOTE: we have to be very careful about this branch
-- on 32 bit machines, because maxBound :: Int < maxBound :: Word32
| intIsValidWord32 n = k (unW# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord32Canonical k)
| n >= 0 && n <= maxWord32 = k (unW# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeNegWordCanonical k)
| n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts
go (TkInteger n : ts) (ConsumeNegWordCanonical k)
| n < 0 = k (unW# (fromIntegral (-1-n))) >>= go ts
go (TkInt n : ts) (ConsumeIntCanonical k) = k (unI# n) >>= go ts
go (TkInteger n : ts) (ConsumeInt k)
| n <= maxInt = k (unI# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeInt8Canonical k)
| n >= minInt8 && n <= maxInt8 = k (unI# n) >>= go ts
go (TkInteger n : ts) (ConsumeInt8Canonical k)
| n >= minInt8 && n <= maxInt8 = k (unI# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeInt16Canonical k)
| n >= minInt16 && n <= maxInt16 = k (unI# n) >>= go ts
go (TkInteger n : ts) (ConsumeInt16Canonical k)
| n >= minInt16 && n <= maxInt16 = k (unI# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeInt32Canonical k)
| n >= minInt32 && n <= maxInt32 = k (unI# n) >>= go ts
go (TkInteger n : ts) (ConsumeInt32Canonical k)
| n >= minInt32 && n <= maxInt32 = k (unI# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeIntegerCanonical k) = k (fromIntegral n) >>= go ts
go (TkInteger n : ts) (ConsumeIntegerCanonical k) = k n >>= go ts
go (TkListLen n : ts) (ConsumeListLenCanonical k)
| n <= maxInt = k (unI# (fromIntegral n)) >>= go ts
go (TkMapLen n : ts) (ConsumeMapLenCanonical k)
| n <= maxInt = k (unI# (fromIntegral n)) >>= go ts
go (TkTag n : ts) (ConsumeTagCanonical k)
| n <= maxWord = k (unW# (fromIntegral n)) >>= go ts
#if defined(ARCH_32bit)
-- 64bit variants for 32bit machines
go (TkInt n : ts) (ConsumeWord64 k)
| n >= 0 = k (unW64# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord64 k)
| n >= 0 = k (unW64# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeNegWord64 k)
| n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts
go (TkInteger n : ts) (ConsumeNegWord64 k)
| n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts
go (TkInt n : ts) (ConsumeInt64 k) = k (unI64# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeInt64 k) = k (unI64# (fromIntegral n)) >>= go ts
go (TkTag n : ts) (ConsumeTag64 k) = k (unW64# n) >>= go ts
go (TkInt n : ts) (ConsumeWord64Canonical k)
| n >= 0 = k (unW64# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeWord64Canonical k)
| n >= 0 = k (unW64# (fromIntegral n)) >>= go ts
go (TkInt n : ts) (ConsumeNegWord64Canonical k)
| n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts
go (TkInteger n : ts) (ConsumeNegWord64Canonical k)
| n < 0 = k (unW64# (fromIntegral (-1-n))) >>= go ts
go (TkInt n : ts) (ConsumeInt64Canonical k) = k (unI64# (fromIntegral n)) >>= go ts
go (TkInteger n : ts) (ConsumeInt64Canonical k) = k (unI64# (fromIntegral n)) >>= go ts
go (TkTag n : ts) (ConsumeTag64Canonical k) = k (unW64# n) >>= go ts
-- TODO FIXME (aseipp/dcoutts): are these going to be utilized?
-- see fallthrough case below if/when fixed.
go ts (ConsumeListLen64 _) = unexpected "decodeListLen64" ts
go ts (ConsumeMapLen64 _) = unexpected "decodeMapLen64" ts
go ts (ConsumeListLen64Canonical _) = unexpected "decodeListLen64Canonical" ts
go ts (ConsumeMapLen64Canonical _) = unexpected "decodeMapLen64Canonical" ts
#endif
go (TkFloat16 f : ts) (ConsumeFloat k) = k (unF# f) >>= go ts
go (TkFloat32 f : ts) (ConsumeFloat k) = k (unF# f) >>= go ts
go (TkFloat16 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts
go (TkFloat32 f : ts) (ConsumeDouble k) = k (unD# (float2Double f)) >>= go ts
go (TkFloat64 f : ts) (ConsumeDouble k) = k (unD# f) >>= go ts
go (TkBytes bs : ts) (ConsumeBytes k) = k bs >>= go ts
go (TkBytes bs : ts) (ConsumeByteArray k) = k (BA.fromByteString bs) >>= go ts
go (TkString st : ts) (ConsumeString k) = k st >>= go ts
go (TkString st : ts) (ConsumeUtf8ByteArray k) = k (BA.fromByteString $ TE.encodeUtf8 st)
>>= go ts
go (TkBool b : ts) (ConsumeBool k) = k b >>= go ts
go (TkSimple n : ts) (ConsumeSimple k) = k (unW8# n) >>= go ts
go (TkFloat16 f : ts) (ConsumeFloat16Canonical k) = k (unF# f) >>= go ts
go (TkFloat32 f : ts) (ConsumeFloatCanonical k) = k (unF# f) >>= go ts
go (TkFloat64 f : ts) (ConsumeDoubleCanonical k) = k (unD# f) >>= go ts
go (TkBytes bs : ts) (ConsumeBytesCanonical k) = k bs >>= go ts
go (TkBytes bs : ts) (ConsumeByteArrayCanonical k) = k (BA.fromByteString bs) >>= go ts
go (TkString st : ts) (ConsumeStringCanonical k) = k st >>= go ts
go (TkString st : ts) (ConsumeUtf8ByteArrayCanonical k) = k (BA.fromByteString $ TE.encodeUtf8 st)
>>= go ts
go (TkSimple n : ts) (ConsumeSimpleCanonical k) = k (unW8# n) >>= go ts
go (TkBytesBegin : ts) (ConsumeBytesIndef da) = da >>= go ts
go (TkStringBegin : ts) (ConsumeStringIndef da) = da >>= go ts
go (TkListBegin : ts) (ConsumeListLenIndef da) = da >>= go ts
go (TkMapBegin : ts) (ConsumeMapLenIndef da) = da >>= go ts
go (TkNull : ts) (ConsumeNull da) = da >>= go ts
go (TkListLen n : ts) (ConsumeListLenOrIndef k)
| n <= maxInt = k (unI# (fromIntegral n)) >>= go ts
go (TkListBegin : ts) (ConsumeListLenOrIndef k) = k (-1#) >>= go ts
go (TkMapLen n : ts) (ConsumeMapLenOrIndef k)
| n <= maxInt = k (unI# (fromIntegral n)) >>= go ts
go (TkMapBegin : ts) (ConsumeMapLenOrIndef k) = k (-1#) >>= go ts
go (TkBreak : ts) (ConsumeBreakOr k) = k True >>= go ts
go ts@(_ : _ ) (ConsumeBreakOr k) = k False >>= go ts
go ts@(tk:_) (PeekTokenType k) = k (tokenTypeOf tk) >>= go ts
go ts (PeekTokenType _) = unexpected "peekTokenType" ts
-- We don't have real bytes so we have to give these two operations
-- different interpretations: remaining tokens and just 0 for offsets.
go ts (PeekAvailable k) = k (unI# (length ts)) >>= go ts
#if defined(ARCH_32bit)
go ts (PeekByteOffset k)= k (unI64# 0) >>= go ts
#else
go ts (PeekByteOffset k)= k 0# >>= go ts
#endif
go _ (Fail msg) = return $ Left msg
go [] (Done x) = return $ Right x
go ts (Done _) = return $ Left ("trailing tokens: " ++ show (take 5 ts))
----------------------------------------------------------------------------
-- Fallthrough cases: unhandled token/DecodeAction combinations
go ts (ConsumeWord _) = unexpected "decodeWord" ts
go ts (ConsumeWord8 _) = unexpected "decodeWord8" ts
go ts (ConsumeWord16 _) = unexpected "decodeWord16" ts
go ts (ConsumeWord32 _) = unexpected "decodeWord32" ts
go ts (ConsumeNegWord _) = unexpected "decodeNegWord" ts
go ts (ConsumeInt _) = unexpected "decodeInt" ts
go ts (ConsumeInt8 _) = unexpected "decodeInt8" ts
go ts (ConsumeInt16 _) = unexpected "decodeInt16" ts
go ts (ConsumeInt32 _) = unexpected "decodeInt32" ts
go ts (ConsumeInteger _) = unexpected "decodeInteger" ts
go ts (ConsumeListLen _) = unexpected "decodeListLen" ts
go ts (ConsumeMapLen _) = unexpected "decodeMapLen" ts
go ts (ConsumeTag _) = unexpected "decodeTag" ts
go ts (ConsumeWordCanonical _) = unexpected "decodeWordCanonical" ts
go ts (ConsumeWord8Canonical _) = unexpected "decodeWord8Canonical" ts
go ts (ConsumeWord16Canonical _) = unexpected "decodeWord16Canonical" ts
go ts (ConsumeWord32Canonical _) = unexpected "decodeWord32Canonical" ts
go ts (ConsumeNegWordCanonical _) = unexpected "decodeNegWordCanonical" ts
go ts (ConsumeIntCanonical _) = unexpected "decodeIntCanonical" ts
go ts (ConsumeInt8Canonical _) = unexpected "decodeInt8Canonical" ts
go ts (ConsumeInt16Canonical _) = unexpected "decodeInt16Canonical" ts
go ts (ConsumeInt32Canonical _) = unexpected "decodeInt32Canonical" ts
go ts (ConsumeIntegerCanonical _) = unexpected "decodeIntegerCanonical" ts
go ts (ConsumeListLenCanonical _) = unexpected "decodeListLenCanonical" ts
go ts (ConsumeMapLenCanonical _) = unexpected "decodeMapLenCanonical" ts
go ts (ConsumeTagCanonical _) = unexpected "decodeTagCanonical" ts
go ts (ConsumeFloat _) = unexpected "decodeFloat" ts
go ts (ConsumeDouble _) = unexpected "decodeDouble" ts
go ts (ConsumeBytes _) = unexpected "decodeBytes" ts
go ts (ConsumeByteArray _) = unexpected "decodeByteArray" ts
go ts (ConsumeString _) = unexpected "decodeString" ts
go ts (ConsumeUtf8ByteArray _) = unexpected "decodeUtf8ByteArray" ts
go ts (ConsumeBool _) = unexpected "decodeBool" ts
go ts (ConsumeSimple _) = unexpected "decodeSimple" ts
go ts (ConsumeFloat16Canonical _) = unexpected "decodeFloat16Canonical" ts
go ts (ConsumeFloatCanonical _) = unexpected "decodeFloatCanonical" ts
go ts (ConsumeDoubleCanonical _) = unexpected "decodeDoubleCanonical" ts
go ts (ConsumeBytesCanonical _) = unexpected "decodeBytesCanonical" ts
go ts (ConsumeByteArrayCanonical _) = unexpected "decodeByteArrayCanonical" ts
go ts (ConsumeStringCanonical _) = unexpected "decodeStringCanonical" ts
go ts (ConsumeUtf8ByteArrayCanonical _) = unexpected "decodeUtf8ByteArrayCanonical" ts
go ts (ConsumeSimpleCanonical _) = unexpected "decodeSimpleCanonical" ts
#if defined(ARCH_32bit)
-- 64bit variants for 32bit machines
go ts (ConsumeWord64 _) = unexpected "decodeWord64" ts
go ts (ConsumeNegWord64 _) = unexpected "decodeNegWord64" ts
go ts (ConsumeInt64 _) = unexpected "decodeInt64" ts
go ts (ConsumeTag64 _) = unexpected "decodeTag64" ts
--go ts (ConsumeListLen64 _) = unexpected "decodeListLen64" ts
--go ts (ConsumeMapLen64 _) = unexpected "decodeMapLen64" ts
go ts (ConsumeWord64Canonical _) = unexpected "decodeWord64Canonical" ts
go ts (ConsumeNegWord64Canonical _) = unexpected "decodeNegWord64Canonical" ts
go ts (ConsumeInt64Canonical _) = unexpected "decodeInt64Canonical" ts
go ts (ConsumeTag64Canonical _) = unexpected "decodeTag64Canonical" ts
--go ts (ConsumeListLen64Canonical _) = unexpected "decodeListLen64Canonical" ts
--go ts (ConsumeMapLen64Canonical _) = unexpected "decodeMapLen64Canonical" ts
#endif
go ts (ConsumeBytesIndef _) = unexpected "decodeBytesIndef" ts
go ts (ConsumeStringIndef _) = unexpected "decodeStringIndef" ts
go ts (ConsumeListLenIndef _) = unexpected "decodeListLenIndef" ts
go ts (ConsumeMapLenIndef _) = unexpected "decodeMapLenIndef" ts
go ts (ConsumeNull _) = unexpected "decodeNull" ts
go ts (ConsumeListLenOrIndef _) = unexpected "decodeListLenOrIndef" ts
go ts (ConsumeMapLenOrIndef _) = unexpected "decodeMapLenOrIndef" ts
go ts (ConsumeBreakOr _) = unexpected "decodeBreakOr" ts
unexpected name [] = return $ Left $ name ++ ": unexpected end of input"
unexpected name (tok:_) = return $ Left $ name ++ ": unexpected token " ++ show tok
-- | Map a 'TermToken' to the underlying CBOR 'TokenType'
tokenTypeOf :: TermToken -> TokenType
tokenTypeOf (TkInt n)
| n >= 0 = TypeUInt
| otherwise = TypeNInt
tokenTypeOf TkInteger{} = TypeInteger
tokenTypeOf TkBytes{} = TypeBytes
tokenTypeOf TkBytesBegin{} = TypeBytesIndef
tokenTypeOf TkString{} = TypeString
tokenTypeOf TkStringBegin{} = TypeStringIndef
tokenTypeOf TkListLen{} = TypeListLen
tokenTypeOf TkListBegin{} = TypeListLenIndef
tokenTypeOf TkMapLen{} = TypeMapLen
tokenTypeOf TkMapBegin{} = TypeMapLenIndef
tokenTypeOf TkTag{} = TypeTag
tokenTypeOf TkBool{} = TypeBool
tokenTypeOf TkNull = TypeNull
tokenTypeOf TkBreak = TypeBreak
tokenTypeOf TkSimple{} = TypeSimple
tokenTypeOf TkFloat16{} = TypeFloat16
tokenTypeOf TkFloat32{} = TypeFloat32
tokenTypeOf TkFloat64{} = TypeFloat64
--------------------------------------------------------------------------------
-- | Ensure a 'FlatTerm' is internally consistent and was created in a valid
-- manner.
--
-- @since 0.2.0.0
validFlatTerm :: FlatTerm -- ^ The input 'FlatTerm'
-> Bool -- ^ 'True' if valid, 'False' otherwise.
validFlatTerm ts =
either (const False) (const True) $ do
ts' <- validateTerm TopLevelSingle ts
case ts' of
[] -> return ()
_ -> Left "trailing data"
-- | A data type used for tracking the position we're at
-- as we traverse a 'FlatTerm' and make sure it's valid.
data Loc = TopLevelSingle
| TopLevelSequence
| InString Int Loc
| InBytes Int Loc
| InListN Int Int Loc
| InList Int Loc
| InMapNKey Int Int Loc
| InMapNVal Int Int Loc
| InMapKey Int Loc
| InMapVal Int Loc
| InTagged Word64 Loc
deriving Show
-- | Validate an arbitrary 'FlatTerm' at an arbitrary location.
validateTerm :: Loc -> FlatTerm -> Either String FlatTerm
validateTerm _loc (TkInt _ : ts) = return ts
validateTerm _loc (TkInteger _ : ts) = return ts
validateTerm _loc (TkBytes _ : ts) = return ts
validateTerm loc (TkBytesBegin : ts) = validateBytes loc 0 ts
validateTerm _loc (TkString _ : ts) = return ts
validateTerm loc (TkStringBegin : ts) = validateString loc 0 ts
validateTerm loc (TkListLen len : ts)
| len <= maxInt = validateListN loc 0 (fromIntegral len) ts
| otherwise = Left "list len too long (> max int)"
validateTerm loc (TkListBegin : ts) = validateList loc 0 ts
validateTerm loc (TkMapLen len : ts)
| len <= maxInt = validateMapN loc 0 (fromIntegral len) ts
| otherwise = Left "map len too long (> max int)"
validateTerm loc (TkMapBegin : ts) = validateMap loc 0 ts
validateTerm loc (TkTag w : ts) = validateTerm (InTagged w loc) ts
validateTerm _loc (TkBool _ : ts) = return ts
validateTerm _loc (TkNull : ts) = return ts
validateTerm loc (TkBreak : _) = unexpectedToken TkBreak loc
validateTerm _loc (TkSimple _ : ts) = return ts
validateTerm _loc (TkFloat16 _ : ts) = return ts
validateTerm _loc (TkFloat32 _ : ts) = return ts
validateTerm _loc (TkFloat64 _ : ts) = return ts
validateTerm loc [] = unexpectedEof loc
unexpectedToken :: TermToken -> Loc -> Either String a
unexpectedToken tok loc = Left $ "unexpected token " ++ show tok
++ ", in context " ++ show loc
unexpectedEof :: Loc -> Either String a
unexpectedEof loc = Left $ "unexpected end of input in context " ++ show loc
validateBytes :: Loc -> Int -> [TermToken] -> Either String [TermToken]
validateBytes _ _ (TkBreak : ts) = return ts
validateBytes ploc i (TkBytes _ : ts) = validateBytes ploc (i+1) ts
validateBytes ploc i (tok : _) = unexpectedToken tok (InBytes i ploc)
validateBytes ploc i [] = unexpectedEof (InBytes i ploc)
validateString :: Loc -> Int -> [TermToken] -> Either String [TermToken]
validateString _ _ (TkBreak : ts) = return ts
validateString ploc i (TkString _ : ts) = validateString ploc (i+1) ts
validateString ploc i (tok : _) = unexpectedToken tok (InString i ploc)
validateString ploc i [] = unexpectedEof (InString i ploc)
validateListN :: Loc -> Int -> Int -> [TermToken] -> Either String [TermToken]
validateListN _ i len ts | i == len = return ts
validateListN ploc i len ts = do
ts' <- validateTerm (InListN i len ploc) ts
validateListN ploc (i+1) len ts'
validateList :: Loc -> Int -> [TermToken] -> Either String [TermToken]
validateList _ _ (TkBreak : ts) = return ts
validateList ploc i ts = do
ts' <- validateTerm (InList i ploc) ts
validateList ploc (i+1) ts'
validateMapN :: Loc -> Int -> Int -> [TermToken] -> Either String [TermToken]
validateMapN _ i len ts | i == len = return ts
validateMapN ploc i len ts = do
ts' <- validateTerm (InMapNKey i len ploc) ts
ts'' <- validateTerm (InMapNVal i len ploc) ts'
validateMapN ploc (i+1) len ts''
validateMap :: Loc -> Int -> [TermToken] -> Either String [TermToken]
validateMap _ _ (TkBreak : ts) = return ts
validateMap ploc i ts = do
ts' <- validateTerm (InMapKey i ploc) ts
ts'' <- validateTerm (InMapVal i ploc) ts'
validateMap ploc (i+1) ts''
--------------------------------------------------------------------------------
-- Utilities
maxInt, minInt, maxWord :: Num n => n
maxInt = fromIntegral (maxBound :: Int)
minInt = fromIntegral (minBound :: Int)
maxWord = fromIntegral (maxBound :: Word)
maxInt8, minInt8, maxWord8 :: Num n => n
maxInt8 = fromIntegral (maxBound :: Int8)
minInt8 = fromIntegral (minBound :: Int8)
maxWord8 = fromIntegral (maxBound :: Word8)
maxInt16, minInt16, maxWord16 :: Num n => n
maxInt16 = fromIntegral (maxBound :: Int16)
minInt16 = fromIntegral (minBound :: Int16)
maxWord16 = fromIntegral (maxBound :: Word16)
maxInt32, minInt32, maxWord32 :: Num n => n
maxInt32 = fromIntegral (maxBound :: Int32)
minInt32 = fromIntegral (minBound :: Int32)
maxWord32 = fromIntegral (maxBound :: Word32)
-- | Do a careful check to ensure an 'Int' is in the
-- range of a 'Word32'.
intIsValidWord32 :: Int -> Bool
intIsValidWord32 n = b1 && b2
where
-- NOTE: this first comparison must use Int for
-- the check, not Word32, in case a negative value
-- is given. Otherwise this check would fail due to
-- overflow.
b1 = n >= 0
-- NOTE: we must convert n to Word32, otherwise,
-- maxWord32 is inferred as Int, and because
-- the maxBound of Word32 is greater than Int,
-- it overflows and this check fails.
b2 = (fromIntegral n :: Word32) <= maxWord32
unI# :: Int -> Int#
unI# (I# i#) = i#
unW# :: Word -> Word#
unW# (W# w#) = w#
unW8# :: Word8 -> Word#
unW8# (W8# w#) = w#
unF# :: Float -> Float#
unF# (F# f#) = f#
unD# :: Double -> Double#
unD# (D# f#) = f#
#if defined(ARCH_32bit)
unW64# :: Word64 -> Word64#
unW64# (W64# w#) = w#
unI64# :: Int64 -> Int64#
unI64# (I64# i#) = i#
#endif