diff --git a/avro.cabal b/avro.cabal --- a/avro.cabal +++ b/avro.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: fb70ba948e5cb538713c28699ed1af9e5f81d4b7fcc982938ed9b462e7511448 +-- hash: 8b98a8b89f40922a3fbe1ab0ebd5a8bef25531bd5d1571b3216bb3b3ed75bed3 name: avro -version: 0.3.3.1 +version: 0.3.4.0 synopsis: Avro serialization support for Haskell description: Avro serialization and deserialization support for Haskell category: Data @@ -51,21 +51,28 @@ exposed-modules: Data.Avro Data.Avro.Decode + Data.Avro.Decode.Get + Data.Avro.Decode.Lazy + Data.Avro.Decode.Lazy.Convert + Data.Avro.Decode.Lazy.Deconflict + Data.Avro.Decode.Lazy.LazyValue Data.Avro.DecodeRaw Data.Avro.Deconflict - Data.Avro.Encode Data.Avro.Deriving + Data.Avro.Deriving.NormSchema + Data.Avro.EitherN + Data.Avro.Encode Data.Avro.EncodeRaw + Data.Avro.FromAvro + Data.Avro.HasAvroSchema Data.Avro.JSON Data.Avro.Schema + Data.Avro.ToAvro Data.Avro.Types + Data.Avro.Types.Value Data.Avro.Zag Data.Avro.Zig - Data.Avro.HasAvroSchema - Data.Avro.FromAvro - Data.Avro.ToAvro other-modules: - Data.Avro.Deriving.NormSchema Paths_avro hs-source-dirs: src @@ -113,6 +120,7 @@ Avro.Codec.NestedSpec Avro.Codec.TextSpec Avro.Codec.ZigZagSpec + Avro.Decode.Lazy.ValuesSpec Avro.Deconflict.Reader Avro.Deconflict.Writer Avro.DeconflictSpec diff --git a/src/Data/Avro/Decode.hs b/src/Data/Avro/Decode.hs --- a/src/Data/Avro/Decode.hs +++ b/src/Data/Avro/Decode.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} module Data.Avro.Decode ( decodeAvro @@ -14,35 +14,36 @@ , GetAvro(..) ) where -import Prelude as P -import Control.Monad (replicateM,when) import qualified Codec.Compression.Zlib as Z +import Control.Monad (replicateM, when) import qualified Data.Aeson as A import qualified Data.Array as Array +import Data.Binary.Get (Get, runGetOrFail) import qualified Data.Binary.Get as G -import Data.Binary.Get (Get,runGetOrFail) import Data.Binary.IEEE754 as IEEE import Data.Bits -import qualified Data.ByteString.Lazy as BL import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.HashMap.Strict as HashMap import Data.Int import Data.List (foldl') -import qualified Data.List.NonEmpty as NE -import Data.Maybe +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map +import Data.Maybe import Data.Monoid ((<>)) -import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Vector as V +import Prelude as P +import Data.Avro.Decode.Get import Data.Avro.DecodeRaw +import Data.Avro.Schema as S +import qualified Data.Avro.Types as T import Data.Avro.Zag -import Data.Avro.Schema as S -import qualified Data.Avro.Types as T -- |Decode bytes into a 'Value' as described by Schema. decodeAvro :: Schema -> BL.ByteString -> Either String (T.Value Type) @@ -62,39 +63,6 @@ Left (_,_,s) -> Left s {-# INLINABLE decodeContainerWith #-} -data ContainerHeader = ContainerHeader - { syncBytes :: !BL.ByteString - , decompress :: BL.ByteString -> Get BL.ByteString - , containedSchema :: !Schema - } - -nrSyncBytes :: Integral sb => sb -nrSyncBytes = 16 - -instance GetAvro ContainerHeader where - getAvro = - do magic <- getFixed avroMagicSize - when (BL.fromStrict magic /= avroMagicBytes) - (fail "Invalid magic number at start of container.") - metadata <- getMap :: Get (Map.Map Text BL.ByteString) -- avro.schema, avro.codec - sync <- BL.fromStrict <$> getFixed nrSyncBytes - codec <- getCodec (Map.lookup "avro.codec" metadata) - schema <- case Map.lookup "avro.schema" metadata of - Nothing -> fail "Invalid container object: no schema." - Just s -> case A.eitherDecode' s of - Left e -> fail ("Can not decode container schema: " <> e) - Right x -> return x - return ContainerHeader { syncBytes = sync, decompress = codec, containedSchema = schema } - where avroMagicSize :: Integral a => a - avroMagicSize = 4 - - avroMagicBytes :: BL.ByteString - avroMagicBytes = BC.pack "Obj" <> BL.pack [1] - - getFixed :: Int -> Get ByteString - getFixed = G.getByteString - - getContainerWith :: (Schema -> Get a) -> Get (Schema, [[a]]) getContainerWith schemaToGet = do ContainerHeader {..} <- getAvro @@ -180,145 +148,3 @@ else do vs <- replicateM (fromIntegral blockLength) (go t) (vs:) <$> getBlocksOf t {-# INLINE getBlocksOf #-} - -class GetAvro a where - getAvro :: Get a - -instance GetAvro ty => GetAvro (Map.Map Text ty) where - getAvro = getMap -instance GetAvro Bool where - getAvro = getBoolean -instance GetAvro Int32 where - getAvro = getInt -instance GetAvro Int64 where - getAvro = getLong -instance GetAvro BL.ByteString where - getAvro = BL.fromStrict <$> getBytes -instance GetAvro ByteString where - getAvro = getBytes -instance GetAvro Text where - getAvro = getString -instance GetAvro Float where - getAvro = getFloat -instance GetAvro Double where - getAvro = getDouble -instance GetAvro String where - getAvro = Text.unpack <$> getString -instance GetAvro a => GetAvro [a] where - getAvro = getArray -instance GetAvro a => GetAvro (Maybe a) where - getAvro = - do t <- getLong - case t of - 0 -> return Nothing - 1 -> Just <$> getAvro - n -> fail $ "Invalid tag for expected {null,a} Avro union, received: " <> show n - -instance GetAvro a => GetAvro (Array.Array Int a) where - getAvro = - do ls <- getAvro - return $ Array.listArray (0,length ls - 1) ls -instance GetAvro a => GetAvro (V.Vector a) where - getAvro = V.fromList <$> getAvro -instance (GetAvro a, Ord a) => GetAvro (Set.Set a) where - getAvro = Set.fromList <$> getAvro - --------------------------------------------------------------------------------- --- Specialized Getters - -getBoolean :: Get Bool -getBoolean = - do w <- G.getWord8 - return (w == 0x01) - --- |Get a 32-bit int (zigzag encoded, max of 5 bytes) -getInt :: Get Int32 -getInt = getZigZag - --- |Get a 64 bit int (zigzag encoded, max of 10 bytes) -getLong :: Get Int64 -getLong = getZigZag - --- |Get an zigzag encoded integral value consuming bytes till the msb is 0. -getZigZag :: (Bits i, Integral i, DecodeRaw i) => Get i -getZigZag = decodeRaw - -getBytes :: Get ByteString -getBytes = - do w <- getLong - G.getByteString (fromIntegral w) - -getString :: Get Text -getString = Text.decodeUtf8 <$> getBytes - --- a la Java: --- Bit 31 (the bit that is selected by the mask 0x80000000) represents the --- sign of the floating-point number. Bits 30-23 (the bits that are --- selected by the mask 0x7f800000) represent the exponent. Bits 22-0 (the --- bits that are selected by the mask 0x007fffff) represent the --- significand (sometimes called the mantissa) of the floating-point --- number. --- --- If the argument is positive infinity, the result is 0x7f800000. --- --- If the argument is negative infinity, the result is 0xff800000. --- --- If the argument is NaN, the result is 0x7fc00000. -getFloat :: Get Float -getFloat = IEEE.wordToFloat <$> G.getWord32le - --- As in Java: --- Bit 63 (the bit that is selected by the mask 0x8000000000000000L) --- represents the sign of the floating-point number. Bits 62-52 (the bits --- that are selected by the mask 0x7ff0000000000000L) represent the --- exponent. Bits 51-0 (the bits that are selected by the mask --- 0x000fffffffffffffL) represent the significand (sometimes called the --- mantissa) of the floating-point number. --- --- If the argument is positive infinity, the result is --- 0x7ff0000000000000L. --- --- If the argument is negative infinity, the result is --- 0xfff0000000000000L. --- --- If the argument is NaN, the result is 0x7ff8000000000000L -getDouble :: Get Double -getDouble = IEEE.wordToDouble <$> G.getWord64le - --------------------------------------------------------------------------------- --- Complex AvroValue Getters - --- getRecord :: GetAvro ty => Get (AvroValue ty) --- getRecord = getAvro - -getArray :: GetAvro ty => Get [ty] -getArray = - do nr <- getLong - if - | nr == 0 -> return [] - | nr < 0 -> - do _len <- getLong - rs <- replicateM (fromIntegral (abs nr)) getAvro - (rs <>) <$> getArray - | otherwise -> - do rs <- replicateM (fromIntegral nr) getAvro - (rs <>) <$> getArray - -getMap :: GetAvro ty => Get (Map.Map Text ty) -getMap = go Map.empty - where - go acc = - do nr <- getLong - if nr == 0 - then return acc - else do m <- Map.fromList <$> replicateM (fromIntegral nr) getKVs - go (Map.union m acc) - getKVs = (,) <$> getString <*> getAvro - --- Safe-ish from integral -sFromIntegral :: forall a b m. (Monad m, Bounded a, Bounded b, Integral a, Integral b) => a -> m b -sFromIntegral a - | aI > fromIntegral (maxBound :: b) || - aI < fromIntegral (minBound :: b) = fail "Integral overflow." - | otherwise = return (fromIntegral a) - where aI = fromIntegral a :: Integer diff --git a/src/Data/Avro/Decode/Get.hs b/src/Data/Avro/Decode/Get.hs new file mode 100644 --- /dev/null +++ b/src/Data/Avro/Decode/Get.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Avro.Decode.Get +where + +import qualified Codec.Compression.Zlib as Z +import Control.Monad (foldM, replicateM, when) +import qualified Data.Aeson as A +import qualified Data.Array as Array +import Data.Binary.Get (Get, runGetOrFail) +import qualified Data.Binary.Get as G +import Data.Binary.IEEE754 as IEEE +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.HashMap.Strict as HashMap +import Data.Int +import Data.List (foldl') +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid ((<>)) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Vector as V +import Prelude as P + +import Data.Avro.DecodeRaw +import Data.Avro.Schema as S +import Data.Avro.Zag + +class GetAvro a where + getAvro :: Get a + +instance GetAvro ty => GetAvro (Map.Map Text ty) where + getAvro = getMap +instance GetAvro Bool where + getAvro = getBoolean +instance GetAvro Int32 where + getAvro = getInt +instance GetAvro Int64 where + getAvro = getLong +instance GetAvro BL.ByteString where + getAvro = BL.fromStrict <$> getBytes +instance GetAvro ByteString where + getAvro = getBytes +instance GetAvro Text where + getAvro = getString +instance GetAvro Float where + getAvro = getFloat +instance GetAvro Double where + getAvro = getDouble +instance GetAvro String where + getAvro = Text.unpack <$> getString +instance GetAvro a => GetAvro [a] where + getAvro = getArray +instance GetAvro a => GetAvro (Maybe a) where + getAvro = + do t <- getLong + case t of + 0 -> return Nothing + 1 -> Just <$> getAvro + n -> fail $ "Invalid tag for expected {null,a} Avro union, received: " <> show n + +instance GetAvro a => GetAvro (Array.Array Int a) where + getAvro = + do ls <- getAvro + return $ Array.listArray (0,length ls - 1) ls +instance GetAvro a => GetAvro (V.Vector a) where + getAvro = V.fromList <$> getAvro +instance (GetAvro a, Ord a) => GetAvro (Set.Set a) where + getAvro = Set.fromList <$> getAvro + + +data ContainerHeader = ContainerHeader + { syncBytes :: !BL.ByteString + , decompress :: BL.ByteString -> Get BL.ByteString + , containedSchema :: !Schema + } + +nrSyncBytes :: Integral sb => sb +nrSyncBytes = 16 + +instance GetAvro ContainerHeader where + getAvro = + do magic <- getFixed avroMagicSize + when (BL.fromStrict magic /= avroMagicBytes) + (fail "Invalid magic number at start of container.") + metadata <- getMap :: Get (Map.Map Text BL.ByteString) -- avro.schema, avro.codec + sync <- BL.fromStrict <$> getFixed nrSyncBytes + codec <- getCodec (Map.lookup "avro.codec" metadata) + schema <- case Map.lookup "avro.schema" metadata of + Nothing -> fail "Invalid container object: no schema." + Just s -> case A.eitherDecode' s of + Left e -> fail ("Can not decode container schema: " <> e) + Right x -> return x + return ContainerHeader { syncBytes = sync, decompress = codec, containedSchema = schema } + where avroMagicSize :: Integral a => a + avroMagicSize = 4 + + avroMagicBytes :: BL.ByteString + avroMagicBytes = BC.pack "Obj" <> BL.pack [1] + + getFixed :: Int -> Get ByteString + getFixed = G.getByteString + + +getCodec :: Monad m => Maybe BL.ByteString -> m (BL.ByteString -> m BL.ByteString) +getCodec code | Just "null" <- code = + return return + | Just "deflate" <- code = + return (either (fail . show) return . Z.decompress) + | Just x <- code = + fail ("Unrecognized codec: " <> BC.unpack x) + | otherwise = return return + + +-------------------------------------------------------------------------------- +-- Specialized Getters + +getBoolean :: Get Bool +getBoolean = + do w <- G.getWord8 + return (w == 0x01) + +-- |Get a 32-bit int (zigzag encoded, max of 5 bytes) +getInt :: Get Int32 +getInt = getZigZag + +-- |Get a 64 bit int (zigzag encoded, max of 10 bytes) +getLong :: Get Int64 +getLong = getZigZag + +-- |Get an zigzag encoded integral value consuming bytes till the msb is 0. +getZigZag :: (Bits i, Integral i, DecodeRaw i) => Get i +getZigZag = decodeRaw + +getBytes :: Get ByteString +getBytes = + do w <- getLong + G.getByteString (fromIntegral w) + +getString :: Get Text +getString = Text.decodeUtf8 <$> getBytes + +-- a la Java: +-- Bit 31 (the bit that is selected by the mask 0x80000000) represents the +-- sign of the floating-point number. Bits 30-23 (the bits that are +-- selected by the mask 0x7f800000) represent the exponent. Bits 22-0 (the +-- bits that are selected by the mask 0x007fffff) represent the +-- significand (sometimes called the mantissa) of the floating-point +-- number. +-- +-- If the argument is positive infinity, the result is 0x7f800000. +-- +-- If the argument is negative infinity, the result is 0xff800000. +-- +-- If the argument is NaN, the result is 0x7fc00000. +getFloat :: Get Float +getFloat = IEEE.wordToFloat <$> G.getWord32le + +-- As in Java: +-- Bit 63 (the bit that is selected by the mask 0x8000000000000000L) +-- represents the sign of the floating-point number. Bits 62-52 (the bits +-- that are selected by the mask 0x7ff0000000000000L) represent the +-- exponent. Bits 51-0 (the bits that are selected by the mask +-- 0x000fffffffffffffL) represent the significand (sometimes called the +-- mantissa) of the floating-point number. +-- +-- If the argument is positive infinity, the result is +-- 0x7ff0000000000000L. +-- +-- If the argument is negative infinity, the result is +-- 0xfff0000000000000L. +-- +-- If the argument is NaN, the result is 0x7ff8000000000000L +getDouble :: Get Double +getDouble = IEEE.wordToDouble <$> G.getWord64le + +-------------------------------------------------------------------------------- +-- Complex AvroValue Getters + +-- getRecord :: GetAvro ty => Get (AvroValue ty) +-- getRecord = getAvro + +getArray :: GetAvro ty => Get [ty] +getArray = + do nr <- getLong + if + | nr == 0 -> return [] + | nr < 0 -> + do _len <- getLong + rs <- replicateM (fromIntegral (abs nr)) getAvro + (rs <>) <$> getArray + | otherwise -> + do rs <- replicateM (fromIntegral nr) getAvro + (rs <>) <$> getArray + +getMap :: GetAvro ty => Get (Map.Map Text ty) +getMap = go Map.empty + where + go acc = + do nr <- getLong + if nr == 0 + then return acc + else do m <- Map.fromList <$> replicateM (fromIntegral nr) getKVs + go (Map.union m acc) + getKVs = (,) <$> getString <*> getAvro + +-- Safe-ish from integral +sFromIntegral :: forall a b m. (Monad m, Bounded a, Bounded b, Integral a, Integral b) => a -> m b +sFromIntegral a + | aI > fromIntegral (maxBound :: b) || + aI < fromIntegral (minBound :: b) = fail "Integral overflow." + | otherwise = return (fromIntegral a) + where aI = fromIntegral a :: Integer diff --git a/src/Data/Avro/Decode/Lazy.hs b/src/Data/Avro/Decode/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Avro/Decode/Lazy.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Data.Avro.Decode.Lazy + ( decodeAvro + , decodeContainer + , decodeContainer' + , decodeContainerWithSchema + , decodeContainerWithSchema' + + -- * Lower level interface + , getContainerValues + , getContainerValuesWith + , getAvroOf + , GetAvro(..) + ) where + +import qualified Codec.Compression.Zlib as Z +import Control.Monad (foldM, replicateM, when) +import qualified Data.Aeson as A +import qualified Data.Array as Array +import Data.Binary.Get (Get, runGetOrFail) +import qualified Data.Binary.Get as G +import Data.Binary.IEEE754 as IEEE +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BC +import Data.Either (isRight) +import qualified Data.HashMap.Strict as HashMap +import Data.Int +import Data.List (foldl') +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid ((<>)) +import qualified Data.Set as Set +import Data.Tagged (Tagged, untag) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Vector as V +import Prelude as P + +import qualified Data.Avro.Decode.Lazy.LazyValue as T +import Data.Avro.DecodeRaw +import Data.Avro.HasAvroSchema (schema) +import Data.Avro.Schema as S +import Data.Avro.Zag + +import Data.Avro.Decode.Get +import Data.Avro.Decode.Lazy.Convert (toStrictValue) +import Data.Avro.Decode.Lazy.Deconflict as C +import Data.Avro.FromAvro + +-- | Decodes the container as a lazy list of values of the requested type. +-- +-- The schema for the requested type will be de-conflicted with the schema +-- embedded with the container. +-- +-- Errors are reported as a part of the list and the list will stop at first +-- error. This means that the consumer will get all the "good" content from +-- the container until the error is detected, then this error and then the list +-- is finished. +decodeContainer :: forall a. FromAvro a => BL.ByteString -> [Either String a] +decodeContainer bs = + let vals = either (\err -> [Left err]) concat (decodeContainer' bs) + in takeWhileInclusive isRight vals + +-- | Decodes the container as a lazy list of values of the requested type. +-- +-- The schema for the requested type will be de-conflicted with the schema +-- embedded with the container. +-- +-- The content of the container is returned as a list of "blocks" of values +-- inside this container, so the notion of blocks in the container is preserved. +-- Since decoding is lazy it should be safe to concat these values into one lazy list. +-- +-- The "outer" error represents the error in opening the container itself +-- (including problems like reading schemas embedded into the container.) +-- +-- The "inner" errors represent problems in decoding individual values. +-- +-- Note that this function will not stop decoding at the first occurance of the "inner" +-- error, and will continue attempting decoding values, so it is possible to +-- get 'Right' after 'Left'. It is up to the user to decide whether it is correct or not to +-- continue after errors (most likely it will not be correct). +-- +-- 'decodeContainer' function makes a choice to stop after the first error. +decodeContainer' :: forall a. FromAvro a => BL.ByteString -> Either String [[Either String a]] +decodeContainer' = decodeContainerWithSchema' (untag (schema :: Tagged a Schema)) + +-- | Same as 'decodeContainer' but uses provided schema as a reader schema for the container +-- instead of the schema obtained from the type of 'a'. +-- +-- It is up to the user to make sure that the provided schema is compatible with 'a' +-- and with the container's writer schema. +decodeContainerWithSchema :: FromAvro a => Schema -> BL.ByteString -> [Either String a] +decodeContainerWithSchema s bs = + either (\err -> [Left err]) concat (decodeContainerWithSchema' s bs) + +-- | Same as 'decodeContainer'' but uses provided schema as a reader schema for the container +-- instead of the schema obtained from the type of 'a'. +-- +-- It is up to the user to make sure that the provided schema is compatible with 'a' +-- and with the container's writer schema. +decodeContainerWithSchema' :: FromAvro a => Schema -> BL.ByteString -> Either String [[Either String a]] +decodeContainerWithSchema' readerSchema bs = do + (writerSchema, vals) <- getContainerValues bs + pure $ (fmap . fmap) (convertValue writerSchema) vals + where + convertValue w v = toStrictValue (C.deconflict w readerSchema v) >>= (resultToEither . fromAvro) + +-- |Decode bytes into a 'Value' as described by Schema. +decodeAvro :: Schema -> BL.ByteString -> T.LazyValue Type +decodeAvro s = snd . getAvroOf s +{-# INLINABLE decodeAvro #-} + +-- | Decodes the container into a list of blocks of raw Avro values. +-- +-- The content of the container is returned as a list of "blocks" of values +-- inside this container, so the notion of blocks in the container is preserved. +-- Since decoding is lazy it should be safe to concat these values into one lazy list. +-- +-- Each 'LazyValue' can be an `Error' and this function doesn't make any attempts +-- of dealing with them leaving it up to the user. +-- +-- The "outer" error represents the error in opening the container itself +-- (including problems like reading schemas embedded into the container.) +getContainerValues :: BC.ByteString -> Either String (Schema, [[T.LazyValue Type]]) +getContainerValues = getContainerValuesWith getAvroOf +{-# INLINABLE getContainerValues #-} + +getContainerValuesWith :: (Schema -> BL.ByteString -> (BL.ByteString, T.LazyValue Type)) + -> BL.ByteString + -> Either String (Schema, [[T.LazyValue Type]]) +getContainerValuesWith schemaToGet bs = + case runGetOrFail getAvro bs of + Left (bs', _, err) -> Left err + Right (bs', _, ContainerHeader {..}) -> + Right (containedSchema, snd $ getBlocks (schemaToGet containedSchema) syncBytes bs' decompress) + where + getRawBlock :: (BL.ByteString -> Get BL.ByteString) -> Get (Int, BC.ByteString) + getRawBlock decompress = do + nrObj <- getLong >>= sFromIntegral + nrBytes <- getLong + bytes <- G.getLazyByteString nrBytes >>= decompress + pure (nrObj, bytes) + + checkMarker :: BL.ByteString -> BL.ByteString -> Either String BL.ByteString + checkMarker sync bs = + case BL.splitAt nrSyncBytes bs of + (marker, _) | marker /= sync -> Left "Invalid marker, does not match sync bytes." + (_, rest) -> Right rest + + getBlocks :: (BL.ByteString -> (BL.ByteString, T.LazyValue Type)) + -> BL.ByteString + -> BL.ByteString + -> (BL.ByteString -> Get BL.ByteString) + -> (BL.ByteString, [[T.LazyValue Type]]) + getBlocks getValue sync bs decompress = + case runGetOrFail (getRawBlock decompress) bs of + Left (bs', _, err) -> (bs', [[T.Error err]]) + Right (bs', _, (nrObj, bytes)) -> + let (_, vs) = consumeN (fromIntegral nrObj) getValue bytes + in case checkMarker sync bs' of + Left err -> (bs', [[T.Error err]]) + Right bs'' | BL.null bs'' -> (bs'', [vs]) + Right bs'' -> + let (rest, vs') = getBlocks getValue bs'' sync decompress + in (rest, vs : vs') + +decodeGet :: GetAvro a => (a -> T.LazyValue Type) -> BL.ByteString -> (BL.ByteString, T.LazyValue Type) +decodeGet f bs = + let res = runGetOrFail (f <$> getAvro) bs + in either (\(rest,_,s) -> (rest, T.Error s)) (\(rest,_,a) -> (rest, a)) res +{-# INLINE decodeGet #-} + +consumeN :: Int64 -> (a -> (a, b)) -> a -> (a, [b]) +consumeN n f a = + if n == 0 + then (a, []) + else + let (a', b) = f a + (r, bs) = consumeN (n-1) f a' + in (r, b:bs) +{-# INLINE consumeN #-} + +getAvroOf :: Schema -> BL.ByteString -> (BL.ByteString, T.LazyValue Type) +getAvroOf ty0 bs = go ty0 bs + where + env = S.buildTypeEnvironment envFail ty0 + envFail t = fail $ "Named type not in schema: " <> show t + + go :: Type -> BL.ByteString -> (BL.ByteString, T.LazyValue Type) + go ty bs = + case ty of + Null -> (bs, T.Null) + Boolean -> decodeGet T.Boolean bs + Int -> decodeGet T.Int bs + Long -> decodeGet T.Long bs + Float -> decodeGet T.Float bs + Double -> decodeGet T.Double bs + Bytes -> decodeGet T.Bytes bs + String -> decodeGet T.String bs + Array t -> T.Array . V.fromList . mconcat <$> getElements bs (go t) + Map t -> T.Map . HashMap.fromList . mconcat <$> getKVPairs bs (go t) + NamedType tn -> + case runGetOrFail (env tn) bs of + Left (bs', _, err) -> (bs', T.Error err) + Right (bs', _, v) -> go v bs' + + Record {..} -> do + let getField bs' Field {..} = (fldName,) <$> go fldType bs' + let flds = foldl' (\(bs', as) fld -> (:as) <$> getField bs' fld ) (bs, []) fields + T.Record ty . HashMap.fromList <$> flds + + Enum {..} -> + case runGetOrFail getLong bs of + Left (bs', _, err) -> (bs', T.Error err) + Right (bs', _, i) -> + case symbolLookup i of + Nothing -> (bs', T.Error ("Unknown value {" <> show i <> "} for enum " <> Text.unpack (typeName ty) )) + Just sym -> (bs', T.Enum ty (fromIntegral i) sym) + + Union ts unionLookup -> + case runGetOrFail getLong bs of + Left (bs', _, err) -> (bs', T.Error err) + Right (bs', _, i) -> + case unionLookup i of + Nothing -> (bs', T.Error $ "Decoded Avro tag is outside the expected range for a Union. Tag: " <> show i <> " union of: " <> show (P.map typeName $ NE.toList ts)) + Just t -> T.Union ts t <$> go t bs' + + Fixed {..} -> + case runGetOrFail (G.getByteString (fromIntegral size)) bs of + Left (bs', _, err) -> (bs', T.Error err) + Right (bs', _, v) -> (bs', T.Fixed ty v) +{-# INLINABLE getAvroOf #-} + +getKVPair getElement bs = + case runGetOrFail getString bs of + Left (bs'', _, err) -> (bs'', ("", T.Error err)) + Right (bs'', _, v) -> (v,) <$> getElement bs'' +{-# INLINE getKVPair #-} + +getKVPairs :: BL.ByteString + -> (BL.ByteString -> (BL.ByteString, T.LazyValue Type)) + -> (BL.ByteString, [[(Text, T.LazyValue Type)]]) +getKVPairs bs getElement = + case runGetOrFail (abs <$> getLong) bs of + Left (bs', _, err) -> (bs', [[("", T.Error err)]]) + Right (bs', _, l) | l == 0 -> (bs', []) + Right (bs', _, l) -> + let (bs'', vs) = consumeN l (getKVPair getElement) bs' + (rest, vs') = getKVPairs bs'' getElement + in (rest, vs : vs') +{-# INLINE getKVPairs #-} + + +getElements :: BL.ByteString + -> (BL.ByteString -> (BL.ByteString, T.LazyValue Type)) + -> (BL.ByteString, [[T.LazyValue Type]]) +getElements bs getElement = + case runGetOrFail (abs <$> getLong) bs of + Left (bs', _, err) -> (bs', [[T.Error err]]) + Right (bs', _, l) | l == 0 -> (bs', []) + Right (bs', _, l) -> + let (bs'', vs) = consumeN l getElement bs' + (rest, vs') = getElements bs'' getElement + in (rest, vs : vs') +{-# INLINE getElements #-} + +-- +takeWhileInclusive :: (a -> Bool) -> [a] -> [a] +takeWhileInclusive _ [] = [] +takeWhileInclusive p (x:xs) = + x : if p x then takeWhileInclusive p xs else [] +{-# INLINE takeWhileInclusive #-} diff --git a/src/Data/Avro/Decode/Lazy/Convert.hs b/src/Data/Avro/Decode/Lazy/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Data/Avro/Decode/Lazy/Convert.hs @@ -0,0 +1,45 @@ +module Data.Avro.Decode.Lazy.Convert +where + +import Data.Avro.Decode.Lazy.LazyValue (LazyValue) +import qualified Data.Avro.Decode.Lazy.LazyValue as D +import Data.Avro.Types.Value (Value) +import qualified Data.Avro.Types.Value as V +import Data.Text (Text) + +toStrictValue :: LazyValue f -> Either String (Value f) +toStrictValue d = case d of + D.Null -> Right V.Null + D.Boolean v -> Right $ V.Boolean v + D.Int v -> Right $ V.Int v + D.Long v -> Right $ V.Long v + D.Float v -> Right $ V.Float v + D.Double v -> Right $ V.Double v + D.Bytes v -> Right $ V.Bytes v + D.String v -> Right $ V.String v + D.Array vs -> V.Array <$> traverse toStrictValue vs + D.Map vs -> V.Map <$> traverse toStrictValue vs + D.Record f vs -> V.Record f <$> traverse toStrictValue vs + D.Union fs f v -> V.Union fs f <$> toStrictValue v + D.Fixed f v -> Right $ V.Fixed f v + D.Enum f i v -> Right $ V.Enum f i v + D.Error v -> Left v +{-# INLINE toStrictValue #-} + +fromStrictValue :: Value f -> LazyValue f +fromStrictValue d = case d of + V.Null -> D.Null + V.Boolean v -> D.Boolean v + V.Int v -> D.Int v + V.Long v -> D.Long v + V.Float v -> D.Float v + V.Double v -> D.Double v + V.Bytes v -> D.Bytes v + V.String v -> D.String v + V.Array vs -> D.Array $ fromStrictValue <$> vs + V.Map vs -> D.Map $ fromStrictValue <$> vs + V.Record f vs -> D.Record f $ fromStrictValue <$> vs + V.Union fs f v -> D.Union fs f $ fromStrictValue v + V.Fixed f v -> D.Fixed f v + V.Enum f i v -> D.Enum f i v +{-# INLINE fromStrictValue #-} diff --git a/src/Data/Avro/Decode/Lazy/Deconflict.hs b/src/Data/Avro/Decode/Lazy/Deconflict.hs new file mode 100644 --- /dev/null +++ b/src/Data/Avro/Decode/Lazy/Deconflict.hs @@ -0,0 +1,117 @@ +module Data.Avro.Decode.Lazy.Deconflict + ( deconflict + ) where + +import Control.Applicative ((<|>)) +import Data.Avro.Decode.Lazy.Convert (fromStrictValue) +import Data.Avro.Decode.Lazy.LazyValue as T +import Data.Avro.Schema as S +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List (find) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.Semigroup ((<>)) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +-- | @deconflict writer reader val@ will convert a value that was +-- encoded/decoded with the writer's schema into the form specified by the +-- reader's schema. +deconflict :: Schema -- ^ Writer schema + -> Schema -- ^ Reader schema + -> T.LazyValue Type + -> T.LazyValue Type +deconflict = resolveSchema + +resolveSchema :: Type -> Type -> T.LazyValue Type -> T.LazyValue Type +resolveSchema writerSchema readerSchema v + | writerSchema == readerSchema = v + | otherwise = go writerSchema readerSchema v + where + go :: Type -> Type -> T.LazyValue Type -> T.LazyValue Type + go _ _ val@(T.Error _) = val + go (S.Array aTy) (S.Array bTy) (T.Array vec) = + T.Array $ fmap (go aTy bTy) vec + go (S.Map aTy) (S.Map bTy) (T.Map mp) = + T.Map $ fmap (go aTy bTy) mp + go a@S.Enum {} b@S.Enum {} val + | name a == name b = resolveEnum a b val + go a@S.Fixed {} b@S.Fixed {} val + | name a == name b && size a == size b = val + go a@S.Record {} b@S.Record {} val + | name a == name b = resolveRecord a b val + go (S.Union _ _) (S.Union ys _) val = + resolveTwoUnions ys val + go nonUnion (S.Union ys _) val = + resolveReaderUnion nonUnion ys val + go (S.Union _xs _) nonUnion val = + resolveWriterUnion nonUnion val + go eTy dTy val = + case val of + T.Int i32 | dTy == S.Long -> T.Long (fromIntegral i32) + | dTy == S.Float -> T.Float (fromIntegral i32) + | dTy == S.Double -> T.Double (fromIntegral i32) + T.Long i64 | dTy == S.Float -> T.Float (fromIntegral i64) + | dTy == S.Double -> T.Double (fromIntegral i64) + T.Float f | dTy == S.Double -> T.Double (realToFrac f) + T.String s | dTy == S.Bytes -> T.Bytes (Text.encodeUtf8 s) + T.Bytes bs | dTy == S.String -> T.String (Text.decodeUtf8 bs) + _ -> T.Error $ "Can not resolve differing writer and reader schemas: " ++ show (eTy, dTy) + +-- The writer's symbol must be present in the reader's enum +resolveEnum :: Type -> Type -> T.LazyValue Type -> T.LazyValue Type +resolveEnum e d val@(T.Enum _ _ _txt) = val + -- -- | txt `elem` symbols d = Right val + -- -- | otherwise = Left "Decoded enum does not appear in reader's symbol list." + +resolveTwoUnions :: NonEmpty Type -> T.LazyValue Type -> T.LazyValue Type +resolveTwoUnions ds (T.Union _ eTy val) = + resolveReaderUnion eTy ds val + +resolveReaderUnion :: Type -> NonEmpty Type -> T.LazyValue Type -> T.LazyValue Type +resolveReaderUnion e ds val = + let hdl [] = T.Error $ "No corresponding union value for " <> Text.unpack (typeName e) + hdl (d:rest) = + case resolveSchema e d val of + T.Error _ -> hdl rest + -- Right (T.Union ds d v) + v -> T.Union ds d v + in hdl (NE.toList ds) + +resolveWriterUnion :: Type -> T.LazyValue Type -> T.LazyValue Type +resolveWriterUnion reader (T.Union _ ty val) = resolveSchema ty reader val + +resolveRecord :: Type -> Type -> T.LazyValue Type -> T.LazyValue Type +resolveRecord writerSchema readerSchema (T.Record ty fldVals) = + T.Record ty . HashMap.fromList $ fmap (resolveFields fldVals (fields writerSchema)) (fields readerSchema) + +-- For each field of the decoders, lookup the field in the hash map +-- 1) If the field exists, call 'resolveSchema' +-- 2) If the field is missing use the reader's default +-- 3) If there is no default, fail. +-- +-- XXX: Consider aliases in the writer schema, use those to retry on failed lookup. +resolveFields :: HashMap Text (T.LazyValue Type) -> [Field] -> Field -> (Text,T.LazyValue Type) +resolveFields hm writerFields readerField = + let + mbWriterField = findField readerField writerFields + mbValue = HashMap.lookup (fldName readerField) hm + in case (mbWriterField, mbValue, fldDefault readerField) of + (Just w, Just x,_) -> (fldName readerField, resolveSchema (fldType w) (fldType readerField) x) + (_, Just x,_) -> (fldName readerField, x) + (_, _,Just def) -> (fldName readerField, fromStrictValue def) + (_,Nothing,Nothing) -> (fldName readerField, T.Error ("No field and no default for " ++ show (fldName readerField))) + +findField :: Field -> [Field] -> Maybe Field +findField f fs = + let + byName = find (\x -> fldName x == fldName f) fs + allNames fld = Set.fromList (fldName fld : fldAliases fld) + fNames = allNames f + sameField = not . Set.null . Set.intersection fNames . allNames + byAliases = find sameField fs + in byName <|> byAliases diff --git a/src/Data/Avro/Decode/Lazy/LazyValue.hs b/src/Data/Avro/Decode/Lazy/LazyValue.hs new file mode 100644 --- /dev/null +++ b/src/Data/Avro/Decode/Lazy/LazyValue.hs @@ -0,0 +1,27 @@ +module Data.Avro.Decode.Lazy.LazyValue +where + +import Data.ByteString +import Data.HashMap.Strict (HashMap) +import Data.Int +import Data.List.NonEmpty (NonEmpty) +import Data.Text +import Data.Vector + +data LazyValue f + = Null + | Boolean Bool + | Int Int32 + | Long Int64 + | Float Float + | Double Double + | Bytes ByteString + | String Text + | Array (Vector (LazyValue f)) -- ^ Dynamically enforced monomorphic type. + | Map (HashMap Text (LazyValue f)) -- ^ Dynamically enforced monomorphic type + | Record f (HashMap Text (LazyValue f)) -- Order and a map + | Union (NonEmpty f) f (LazyValue f) -- ^ Set of union options, schema for selected option, and the actual value. + | Fixed f ByteString + | Enum f Int Text -- ^ An enum is a set of the possible symbols (the schema) and the selected symbol + | Error !String + deriving (Eq, Show) diff --git a/src/Data/Avro/Deriving.hs b/src/Data/Avro/Deriving.hs --- a/src/Data/Avro/Deriving.hs +++ b/src/Data/Avro/Deriving.hs @@ -45,6 +45,7 @@ import Language.Haskell.TH.Syntax import Data.Avro.Deriving.NormSchema +import Data.Avro.EitherN import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS @@ -233,6 +234,7 @@ genFromAvro _ = pure [] genFromAvroFieldsExp :: Name -> [Field] -> Q Exp +genFromAvroFieldsExp n [] = [| (return . return) $(conE n) |] genFromAvroFieldsExp n (x:xs) = [| \r -> $(let extract fld = [| r .: T.pack $(mkTextLit (fldName fld))|] @@ -424,7 +426,10 @@ S.Union (Null :| [x]) _ -> [t| Maybe $(mkFieldTypeName x) |] -- AppT (ConT $ mkName "Maybe") (mkFieldTypeName x) S.Union (x :| [Null]) _ -> [t| Maybe $(mkFieldTypeName x) |] --AppT (ConT $ mkName "Maybe") (mkFieldTypeName x) S.Union (x :| [y]) _ -> [t| Either $(mkFieldTypeName x) $(mkFieldTypeName y) |] -- AppT (AppT (ConT (mkName "Either")) (mkFieldTypeName x)) (mkFieldTypeName y) - S.Union (_ :| _) _ -> error "Unions with more than 2 elements are not yet supported" + S.Union (a :| [b, c]) _ -> [t| Either3 $(mkFieldTypeName a) $(mkFieldTypeName b) $(mkFieldTypeName c) |] + S.Union (a :| [b, c, d]) _ -> [t| Either4 $(mkFieldTypeName a) $(mkFieldTypeName b) $(mkFieldTypeName c) $(mkFieldTypeName d) |] + S.Union (a :| [b, c, d, e]) _ -> [t| Either5 $(mkFieldTypeName a) $(mkFieldTypeName b) $(mkFieldTypeName c) $(mkFieldTypeName d) $(mkFieldTypeName e) |] + S.Union _ _ -> error "Unions with more than 5 elements are not yet supported" S.Record n _ _ _ _ _ -> [t| $(conT $ mkDataTypeName n) |] S.Map x -> [t| Map Text $(mkFieldTypeName x) |] --AppT (AppT (ConT (mkName "Map")) (ConT $ mkName "Text")) (mkFieldTypeName x) S.Array x -> [t| [$(mkFieldTypeName x)] |]--AppT (ConT $ Text "[]") (mkFieldTypeName x) diff --git a/src/Data/Avro/EitherN.hs b/src/Data/Avro/EitherN.hs new file mode 100644 --- /dev/null +++ b/src/Data/Avro/EitherN.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Avro.EitherN where + +import Data.Avro +import Data.Avro.Schema +import qualified Data.Avro.Types as T +import Data.Tagged +import Data.List.NonEmpty +import GHC.Generics (Generic) + +data Either3 a b c = E3_1 a | E3_2 b | E3_3 c deriving (Eq, Ord, Show, Generic) + +data Either4 a b c d = E4_1 a | E4_2 b | E4_3 c | E4_4 d deriving (Eq, Ord, Show, Generic) + +data Either5 a b c d e = E5_1 a | E5_2 b | E5_3 c | E5_4 d | E5_5 e deriving (Eq, Ord, Show, Generic) + +instance (HasAvroSchema a, HasAvroSchema b, HasAvroSchema c) => HasAvroSchema (Either3 a b c) where + schema = Tagged $ mkUnion (untag (schema :: Tagged a Type) :| [ + untag (schema :: Tagged b Type), + untag (schema :: Tagged c Type) + ]) + +instance (HasAvroSchema a, HasAvroSchema b, HasAvroSchema c, HasAvroSchema d) => HasAvroSchema (Either4 a b c d) where + schema = Tagged $ mkUnion (untag (schema :: Tagged a Type) :| [ + untag (schema :: Tagged b Type), + untag (schema :: Tagged c Type), + untag (schema :: Tagged d Type) + ]) + +instance (HasAvroSchema a, HasAvroSchema b, HasAvroSchema c, HasAvroSchema d, HasAvroSchema e) => HasAvroSchema (Either5 a b c d e) where + schema = Tagged $ mkUnion (untag (schema :: Tagged a Type) :| [ + untag (schema :: Tagged b Type), + untag (schema :: Tagged c Type), + untag (schema :: Tagged d Type), + untag (schema :: Tagged e Type) + ]) + +instance (FromAvro a, FromAvro b, FromAvro c) => FromAvro (Either3 a b c) where + fromAvro e@(T.Union _ branch x) + | matches branch schemaA = E3_1 <$> fromAvro x + | matches branch schemaB = E3_2 <$> fromAvro x + | matches branch schemaC = E3_3 <$> fromAvro x + | otherwise = badValue e "either3" + where Tagged schemaA = schema :: Tagged a Type + Tagged schemaB = schema :: Tagged b Type + Tagged schemaC = schema :: Tagged c Type + fromAvro x = badValue x "either3" + +instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d) => FromAvro (Either4 a b c d) where + fromAvro e@(T.Union _ branch x) + | matches branch schemaA = E4_1 <$> fromAvro x + | matches branch schemaB = E4_2 <$> fromAvro x + | matches branch schemaC = E4_3 <$> fromAvro x + | matches branch schemaD = E4_4 <$> fromAvro x + | otherwise = badValue e "either4" + where Tagged schemaA = schema :: Tagged a Type + Tagged schemaB = schema :: Tagged b Type + Tagged schemaC = schema :: Tagged c Type + Tagged schemaD = schema :: Tagged d Type + fromAvro x = badValue x "either4" + +instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d, FromAvro e) => FromAvro (Either5 a b c d e) where + fromAvro e@(T.Union _ branch x) + | matches branch schemaA = E5_1 <$> fromAvro x + | matches branch schemaB = E5_2 <$> fromAvro x + | matches branch schemaC = E5_3 <$> fromAvro x + | matches branch schemaD = E5_4 <$> fromAvro x + | matches branch schemaE = E5_5 <$> fromAvro x + | otherwise = badValue e "either5" + where Tagged schemaA = schema :: Tagged a Type + Tagged schemaB = schema :: Tagged b Type + Tagged schemaC = schema :: Tagged c Type + Tagged schemaD = schema :: Tagged d Type + Tagged schemaE = schema :: Tagged e Type + fromAvro x = badValue x "either5" + +instance (ToAvro a, ToAvro b, ToAvro c) => ToAvro (Either3 a b c) where + toAvro e = + let sch@(one :| [two, three]) = options (schemaOf e) + in case e of + E3_1 a -> T.Union sch one (toAvro a) + E3_2 b -> T.Union sch two (toAvro b) + E3_3 c -> T.Union sch three (toAvro c) + +instance (ToAvro a, ToAvro b, ToAvro c, ToAvro d) => ToAvro (Either4 a b c d) where + toAvro e = + let sch@(one :| [two, three, four]) = options (schemaOf e) + in case e of + E4_1 a -> T.Union sch one (toAvro a) + E4_2 b -> T.Union sch two (toAvro b) + E4_3 c -> T.Union sch three (toAvro c) + E4_4 d -> T.Union sch four (toAvro d) + +instance (ToAvro a, ToAvro b, ToAvro c, ToAvro d, ToAvro e) => ToAvro (Either5 a b c d e) where + toAvro e = + let sch@(one :| [two, three, four, five]) = options (schemaOf e) + in case e of + E5_1 a -> T.Union sch one (toAvro a) + E5_2 b -> T.Union sch two (toAvro b) + E5_3 c -> T.Union sch three (toAvro c) + E5_4 d -> T.Union sch four (toAvro d) + E5_5 e -> T.Union sch five (toAvro e) diff --git a/src/Data/Avro/Schema.hs b/src/Data/Avro/Schema.hs --- a/src/Data/Avro/Schema.hs +++ b/src/Data/Avro/Schema.hs @@ -25,6 +25,7 @@ , typeName , buildTypeEnvironment , Result(..) + , resultToEither , matches @@ -349,7 +350,14 @@ Ty.Enum _ _ txt -> A.String txt data Result a = Success a | Error String - deriving (Eq,Ord,Show) + deriving (Eq, Ord, Show) + +resultToEither :: Result b -> Either String b +resultToEither r = + case r of + Success v -> Right v + Error err -> Left err +{-# INLINE resultToEither #-} instance Monad Result where return = pure diff --git a/src/Data/Avro/Types.hs b/src/Data/Avro/Types.hs --- a/src/Data/Avro/Types.hs +++ b/src/Data/Avro/Types.hs @@ -1,25 +1,6 @@ -module Data.Avro.Types where - -import Data.ByteString -import Data.HashMap.Strict (HashMap) -import Data.Int -import Data.List.NonEmpty (NonEmpty) -import Data.Text -import Data.Vector +module Data.Avro.Types +( module X +) +where -data Value f - = Null - | Boolean !Bool - | Int {-# UNPACK #-} !Int32 - | Long {-# UNPACK #-} !Int64 - | Float {-# UNPACK #-} !Float - | Double {-# UNPACK #-} !Double - | Bytes {-# UNPACK #-} !ByteString - | String {-# UNPACK #-} !Text - | Array (Vector (Value f)) -- ^ Dynamically enforced monomorphic type. - | Map (HashMap Text (Value f)) -- ^ Dynamically enforced monomorphic type - | Record f (HashMap Text (Value f)) -- Order and a map - | Union (NonEmpty f) f (Value f) -- ^ Set of union options, schema for selected option, and the actual value. - | Fixed f {-# UNPACK #-} !ByteString - | Enum f {-# UNPACK #-} !Int Text -- ^ An enum is a set of the possible symbols (the schema) and the selected symbol - deriving (Eq, Show) +import Data.Avro.Types.Value as X diff --git a/src/Data/Avro/Types/Value.hs b/src/Data/Avro/Types/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/Avro/Types/Value.hs @@ -0,0 +1,25 @@ +module Data.Avro.Types.Value where + +import Data.ByteString +import Data.HashMap.Strict (HashMap) +import Data.Int +import Data.List.NonEmpty (NonEmpty) +import Data.Text +import Data.Vector + +data Value f + = Null + | Boolean !Bool + | Int {-# UNPACK #-} !Int32 + | Long {-# UNPACK #-} !Int64 + | Float {-# UNPACK #-} !Float + | Double {-# UNPACK #-} !Double + | Bytes {-# UNPACK #-} !ByteString + | String {-# UNPACK #-} !Text + | Array (Vector (Value f)) -- ^ Dynamically enforced monomorphic type. + | Map (HashMap Text (Value f)) -- ^ Dynamically enforced monomorphic type + | Record f (HashMap Text (Value f)) -- Order and a map + | Union (NonEmpty f) f (Value f) -- ^ Set of union options, schema for selected option, and the actual value. + | Fixed f {-# UNPACK #-} !ByteString + | Enum f {-# UNPACK #-} !Int Text -- ^ An enum is a set of the possible symbols (the schema) and the selected symbol + deriving (Eq, Show) diff --git a/test/Avro/Decode/Lazy/ValuesSpec.hs b/test/Avro/Decode/Lazy/ValuesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Avro/Decode/Lazy/ValuesSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Avro.Decode.Lazy.ValuesSpec +where + +import Data.Avro +import Data.Avro.Decode.Lazy +import Data.Avro.Decode.Lazy.Convert as TC +import Data.Avro.Deriving +import Data.Either (isLeft) + +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +deriveAvro "test/data/small.avsc" + +spec :: Spec +spec = describe "Avro.Decode.Lazy.ValueSpec" $ do + let msg = Endpoint + { endpointIps = ["192.168.1.1", "127.0.0.1"] + , endpointPorts = [PortRange 1 10, PortRange 11 20] + , endpointOpaque = Opaque "16-b-long-string" + , endpointCorrelation = Opaque "opaq-correlation" + , endpointTag = Left 14 + } + + it "should lazily decode correct value" $ do + let lazyValue = decodeAvro schema'Endpoint (encode msg) + TC.toStrictValue lazyValue `shouldBe` Right (toAvro msg) + + it "should return an error for a wrong content" $ do + let lazyValue = decodeAvro schema'Endpoint "nonsense lives here" + TC.toStrictValue lazyValue `shouldSatisfy` isLeft