avro 0.5.2.1 → 0.6.2.1
raw patch · 27 files changed
Files
- README.md +27/−25
- avro.cabal +48/−42
- bench/Bench/Deconflict.hs +5/−4
- bench/Bench/Encoding.hs +3/−4
- bench/Main.hs +19/−11
- src/Data/Avro.hs +17/−17
- src/Data/Avro/Codec.hs +6/−7
- src/Data/Avro/Deriving.hs +161/−151
- src/Data/Avro/Deriving/Lift.hs +2/−20
- src/Data/Avro/Deriving/NormSchema.hs +12/−15
- src/Data/Avro/EitherN.hs +8/−0
- src/Data/Avro/Encoding/FromAvro.hs +48/−34
- src/Data/Avro/Encoding/ToAvro.hs +29/−7
- src/Data/Avro/HasAvroSchema.hs +7/−5
- src/Data/Avro/Internal/Container.hs +85/−49
- src/Data/Avro/Internal/Get.hs +1/−9
- src/Data/Avro/Internal/Time.hs +12/−2
- src/Data/Avro/JSON.hs +6/−2
- src/Data/Avro/Schema/Decimal.hs +14/−7
- src/Data/Avro/Schema/Deconflict.hs +6/−13
- src/Data/Avro/Schema/ReadSchema.hs +1/−2
- src/Data/Avro/Schema/Schema.hs +204/−73
- test/Avro/Data/Logical.hs +20/−2
- test/Avro/Data/TwoBits.hs +64/−0
- test/Avro/DefaultsSpec.hs +3/−2
- test/Avro/Gen/Schema.hs +3/−1
- test/Avro/NormSchemaSpec.hs +9/−3
README.md view
@@ -1,6 +1,6 @@ # Native Haskell implementation of Avro -[](https://circleci.com/gh/haskell-works/avro)+[](https://github.com/haskell-works/avro/actions/workflows/haskell.yml) [](https://hackage.haskell.org/package/avro) This is a Haskell [Avro](https://avro.apache.org/) library useful for decoding@@ -29,7 +29,7 @@ { "name": "fullName", "type": "string" }, { "name": "age", "type": "int" }, { "name": "gender",- "type": { "type": "enum", "symbols": ["Male", "Female"] }+ "type": { "name": "Gender", "type": "enum", "symbols": ["Male", "Female"] } }, { "name": "ssn", "type": ["null", "string"] } ]@@ -196,28 +196,30 @@ This library provides the following conversions between Haskell types and Avro types: -| Haskell type | Avro type |-|:------------------|:--------------------------------------------------------|-| () | "null" |-| Bool | "boolean" |-| Int, Int64 | "long" |-| Int32 | "int" |-| Double | "double" |-| Text | "string" |-| ByteString | "bytes" |-| Maybe a | ["null", "a"] |-| Either a b | ["a", "b"] |-| Identity a | ["a"] |-| Map Text a | { "type": "map", "value": "a" } |-| Map String a | { "type": "map", "value": "a" } |-| HashMap Text a | { "type": "map", "value": "a" } |-| HashMap String a | { "type": "map", "value": "a" } |-| [a] | { "type": "array", "value": "a" } |-| UTCTime | { "type": "long", "logicalType": "timestamp-millis" } |-| UTCTime | { "type": "long", "logicalType": "timestamp-micros" } |-| DiffTime | { "type": "int", "logicalType": "time-millis" } |-| DiffTime | { "type": "long", "logicalType": "time-micros" } |-| Day | { "type": "int", "logicalType": "date" } |-| UUID | { "type": "string", "logicalType": "uuid" } |+| Haskell type | Avro type |+|:-----------------|:--------------------------------------------------------------|+| () | "null" |+| Bool | "boolean" |+| Int, Int64 | "long" |+| Int32 | "int" |+| Double | "double" |+| Text | "string" |+| ByteString | "bytes" |+| Maybe a | ["null", "a"] |+| Either a b | ["a", "b"] |+| Identity a | ["a"] |+| Map Text a | { "type": "map", "value": "a" } |+| Map String a | { "type": "map", "value": "a" } |+| HashMap Text a | { "type": "map", "value": "a" } |+| HashMap String a | { "type": "map", "value": "a" } |+| [a] | { "type": "array", "value": "a" } |+| UTCTime | { "type": "long", "logicalType": "timestamp-millis" } |+| UTCTime | { "type": "long", "logicalType": "timestamp-micros" } |+| LocalTime | { "type": "long", "logicalType": "local-timestamp-millis" } |+| LocalTime | { "type": "long", "logicalType": "local-timestamp-micros" } |+| DiffTime | { "type": "int", "logicalType": "time-millis" } |+| DiffTime | { "type": "long", "logicalType": "time-micros" } |+| Day | { "type": "int", "logicalType": "date" } |+| UUID | { "type": "string", "logicalType": "uuid" } | User defined data types should provide `HasAvroSchema` / `ToAvro` / `FromAvro` instances to be encoded/decoded to/from Avro.
avro.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: avro-version: 0.5.2.1+version: 0.6.2.1 synopsis: Avro serialization support for Haskell description: Avro serialization and deserialization support for Haskell category: Data@@ -11,7 +11,7 @@ maintainer: Alexey Raga <alexey.raga@gmail.com> license: BSD-3-Clause license-file: LICENSE-tested-with: GHC == 8.10.2, GHC == 8.8.3, GHC == 8.6.5+tested-with: GHC == 9.10.1, GHC == 9.8.2, GHC == 9.6.6 build-type: Simple extra-source-files: README.md ChangeLog.md@@ -44,50 +44,54 @@ manual: True default: False -common base { build-depends: base >= 4 && < 5 }+common base { build-depends: base >= 4 && < 5 } -common aeson { build-depends: aeson }-common array { build-depends: array }-common base16-bytestring { build-depends: base16-bytestring }-common bifunctors { build-depends: bifunctors }-common big-decimal { build-depends: HasBigDecimal }-common binary { build-depends: binary }-common bytestring { build-depends: bytestring }-common containers { build-depends: containers }-common data-binary-ieee754 { build-depends: data-binary-ieee754 }-common deepseq { build-depends: deepseq }-common directory { build-depends: directory }-common doctest { build-depends: doctest >= 0.16.2 && < 0.19 }-common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 }-common extra { build-depends: extra }-common fail { build-depends: fail }-common gauge { build-depends: gauge }-common generic-lens { build-depends: generic-lens >= 1.2 && < 2.1 }-common hashable { build-depends: hashable }-common hedgehog { build-depends: hedgehog }-common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog }-common hspec { build-depends: hspec }-common lens { build-depends: lens }-common lens-aeson { build-depends: lens-aeson }-common mtl { build-depends: mtl }-common QuickCheck { build-depends: QuickCheck }-common random { build-depends: random }-common raw-strings-qq { build-depends: raw-strings-qq }-common scientific { build-depends: scientific }-common semigroups { build-depends: semigroups }-common tagged { build-depends: tagged }-common text { build-depends: text >= 1.2.3 && < 1.3 }-common time { build-depends: time }-common template-haskell { build-depends: template-haskell >= 2.4 && < 3 }-common tf-random { build-depends: tf-random }-common transformers { build-depends: transformers }-common unordered-containers { build-depends: unordered-containers }-common uuid { build-depends: uuid }-common vector { build-depends: vector }-common zlib { build-depends: zlib }+common aeson { build-depends: aeson >= 2.0.1.0 }+common array { build-depends: array }+common base16-bytestring { build-depends: base16-bytestring }+common bifunctors { build-depends: bifunctors }+common big-decimal { build-depends: HasBigDecimal >= 0.2 && < 0.3 }+common binary { build-depends: binary }+common bytestring { build-depends: bytestring }+common containers { build-depends: containers }+common data-binary-ieee754 { build-depends: data-binary-ieee754 }+common deepseq { build-depends: deepseq }+common directory { build-depends: directory }+common doctest { build-depends: doctest >= 0.16.2 && < 0.23 }+common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 }+common extra { build-depends: extra }+common fail { build-depends: fail }+common generic-lens { build-depends: generic-lens >= 1.2 && < 2.3 }+common hashable { build-depends: hashable }+common hedgehog { build-depends: hedgehog }+common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog }+common hspec { build-depends: hspec }+common lens { build-depends: lens }+common lens-aeson { build-depends: lens-aeson }+common mtl { build-depends: mtl }+common QuickCheck { build-depends: QuickCheck }+common random { build-depends: random }+common raw-strings-qq { build-depends: raw-strings-qq }+common scientific { build-depends: scientific }+common semigroups { build-depends: semigroups }+common tagged { build-depends: tagged }+common text { build-depends: text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2 }+common time { build-depends: time }+common template-haskell { build-depends: template-haskell >= 2.4 && < 3 }+common tf-random { build-depends: tf-random }+common th-lift-instances { build-depends: th-lift-instances }+common transformers { build-depends: transformers >= 0.5.6.2 && < 0.7 }+common unordered-containers { build-depends: unordered-containers }+common uuid { build-depends: uuid }+common vector { build-depends: vector }+common zlib { build-depends: zlib } +common gauge { build-depends: criterion }+ common config default-language: Haskell2010+ ghc-options: -Wall+ if flag(dev) ghc-options: -Wall -Werror @@ -113,6 +117,7 @@ , text , time , tf-random+ , th-lift-instances , unordered-containers , uuid , vector@@ -206,6 +211,7 @@ Avro.Data.Maybe Avro.Data.Recursive Avro.Data.Reused+ Avro.Data.TwoBits Avro.Data.Unions Avro.Decode.ContainerSpec Avro.Decode.RawBlocksSpec
bench/Bench/Deconflict.hs view
@@ -8,7 +8,7 @@ ) where -import Data.Avro (decodeContainerWithReaderSchema, decodeValue, decodeValueWithSchema, encodeContainerWithSchema, encodeValueWithSchema, nullCodec)+import Data.Avro (decodeContainerWithReaderSchema, decodeValueWithSchema, encodeContainerWithSchema, encodeValueWithSchema, nullCodec) import Data.Avro.Schema.ReadSchema (fromSchema) import Data.Vector (Vector) @@ -17,7 +17,8 @@ import qualified Data.Vector as Vector import qualified System.Random as Random -import Gauge+-- import Gauge+import Criterion.Main newOuter :: IO W.Outer newOuter = do@@ -29,12 +30,12 @@ many = Vector.replicateM values :: Benchmark-values = env (many 1e5 $ encodeValueWithSchema W.schema'Outer <$> newOuter) $ \ values ->+values = env (many 1e5 $ encodeValueWithSchema W.schema'Outer <$> newOuter) $ \ vs -> let readSchema = fromSchema W.schema'Outer in bgroup "Encoded: ByteString" [ bgroup "No Deconflict"- [ bench "Read via FromAvro" $ nf (fmap (decodeValueWithSchema @W.Outer readSchema)) values+ [ bench "Read via FromAvro" $ nf (fmap (decodeValueWithSchema @W.Outer readSchema)) vs ] ]
bench/Bench/Encoding.hs view
@@ -16,17 +16,16 @@ where import Control.DeepSeq-import Data.Avro (decodeContainerWithEmbeddedSchema, encodeContainer, encodeContainerWithSchema, encodeValueWithSchema, nullCodec)+import Data.Avro (decodeContainerWithEmbeddedSchema, encodeValueWithSchema, nullCodec) import qualified Data.Avro as Avro import Data.Avro.Deriving (deriveAvroFromByteString, r)-import Data.ByteString (ByteString)-import Data.ByteString.Builder import qualified Data.ByteString.Lazy as BL import Data.List (unfoldr) import qualified Data.Vector as Vector import qualified System.Random as Random -import Gauge+-- import Gauge+import Criterion.Main deriveAvroFromByteString [r| {
bench/Main.hs view
@@ -1,18 +1,26 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-}-module Main-where +module Main where++-- #if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH) import qualified Bench.Deconflict as Deconflict import qualified Bench.Encoding as Encoding--import Gauge+import Criterion.Main+-- import Gauge+-- #endif main :: IO ()-main = defaultMain- [ Deconflict.values- , Encoding.encodeToBS- , Encoding.encodeContainer- , Encoding.roundtripContainer- , Deconflict.container- ]+main =+-- #if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)+ defaultMain+ [ Deconflict.values+ , Encoding.encodeToBS+ , Encoding.encodeContainer+ , Encoding.roundtripContainer+ , Deconflict.container+ ]+-- #else+-- return ()+-- #endif
src/Data/Avro.hs view
@@ -68,7 +68,7 @@ import qualified Data.Avro.Schema.Schema as Schema import Data.Binary.Get (runGetOrFail) import Data.ByteString.Builder (toLazyByteString)-import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy as Lazy import Data.Tagged (untag) {- HLINT ignore "Use section" -}@@ -80,21 +80,21 @@ {-# INLINE readSchemaFromSchema #-} -- | Serialises an individual value into Avro with the schema provided.-encodeValueWithSchema :: ToAvro a => Schema -> a -> BL.ByteString+encodeValueWithSchema :: ToAvro a => Schema -> a -> Lazy.ByteString encodeValueWithSchema s = toLazyByteString . toAvro s {-# INLINE encodeValueWithSchema #-} -- | Serialises an individual value into Avro using the schema -- from its coresponding 'HasAvroSchema' instance.-encodeValue :: (HasAvroSchema a, ToAvro a) => a -> BL.ByteString+encodeValue :: (HasAvroSchema a, ToAvro a) => a -> Lazy.ByteString encodeValue a = encodeValueWithSchema (schemaOf a) a {-# INLINE encodeValue #-} -- | Deserialises an individual value from Avro.-decodeValueWithSchema :: FromAvro a => ReadSchema -> BL.ByteString -> Either String a-decodeValueWithSchema schema payload =- case runGetOrFail (getValue schema) payload of- Right (bs, _, v) -> fromAvro v+decodeValueWithSchema :: FromAvro a => ReadSchema -> Lazy.ByteString -> Either String a+decodeValueWithSchema readSchema payload =+ case runGetOrFail (getValue readSchema) payload of+ Right (_, _, v) -> fromAvro v Left (_, _, e) -> Left e -- | Deserialises an individual value from Avro using the schema from its coresponding 'HasAvroSchema'.@@ -102,7 +102,7 @@ -- __NOTE__: __This function is only to be used when reader and writes schemas are known to be the same.__ -- Because only one schema is known at this point, and it is the reader schema, -- /no decondlicting/ can be performed.-decodeValue :: forall a. (HasAvroSchema a, FromAvro a) => BL.ByteString -> Either String a+decodeValue :: forall a. (HasAvroSchema a, FromAvro a) => Lazy.ByteString -> Either String a decodeValue = decodeValueWithSchema (fromSchema (untag @a schema)) {-# INLINE decodeValue #-} @@ -112,7 +112,7 @@ -- 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. (HasAvroSchema a, FromAvro a) => BL.ByteString -> [Either String a]+decodeContainer :: forall a. (HasAvroSchema a, FromAvro a) => Lazy.ByteString -> [Either String a] decodeContainer = decodeContainerWithReaderSchema (untag @a schema) {-# INLINE decodeContainer #-} @@ -122,7 +122,7 @@ -- 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.-decodeContainerWithEmbeddedSchema :: forall a. FromAvro a => BL.ByteString -> [Either String a]+decodeContainerWithEmbeddedSchema :: forall a. FromAvro a => Lazy.ByteString -> [Either String a] decodeContainerWithEmbeddedSchema payload = case Container.extractContainerValues (pure . fromSchema) (getValue >=> (either fail pure . fromAvro)) payload of Left err -> [Left err]@@ -137,7 +137,7 @@ -- 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.-decodeContainerWithReaderSchema :: forall a. FromAvro a => Schema -> BL.ByteString -> [Either String a]+decodeContainerWithReaderSchema :: forall a. FromAvro a => Schema -> Lazy.ByteString -> [Either String a] decodeContainerWithReaderSchema readerSchema payload = case Container.extractContainerValues (flip deconflict readerSchema) (getValue >=> (either fail pure . fromAvro)) payload of Left err -> [Left err]@@ -148,7 +148,7 @@ -- This is particularly useful when slicing up containers into one or more -- smaller files. By extracting the original bytestring it is possible to -- avoid re-encoding data.-extractContainerValuesBytes :: BL.ByteString -> Either String (Schema, [Either String BL.ByteString])+extractContainerValuesBytes :: Lazy.ByteString -> Either String (Schema, [Either String Lazy.ByteString]) extractContainerValuesBytes = (fmap . fmap . fmap . fmap) snd . Container.extractContainerValuesBytes (pure . fromSchema) getValue {-# INLINE extractContainerValuesBytes #-}@@ -161,8 +161,8 @@ -- avoid re-encoding data. decodeContainerValuesBytes :: forall a. FromAvro a => Schema- -> BL.ByteString- -> Either String (Schema, [Either String (a, BL.ByteString)])+ -> Lazy.ByteString+ -> Either String (Schema, [Either String (a, Lazy.ByteString)]) decodeContainerValuesBytes readerSchema = Container.extractContainerValuesBytes (flip deconflict readerSchema) (getValue >=> (either fail pure . fromAvro)) {-# INLINE decodeContainerValuesBytes #-}@@ -170,19 +170,19 @@ -- | Encode chunks of values into a container, using 16 random bytes for -- the synchronization markers and a corresponding 'HasAvroSchema' schema. -- Blocks are compressed (or not) according to the given 'Codec' ('nullCodec' or 'deflateCodec').-encodeContainer :: forall a. (HasAvroSchema a, ToAvro a) => Codec -> [[a]] -> IO BL.ByteString+encodeContainer :: forall a. (HasAvroSchema a, ToAvro a) => Codec -> [[a]] -> IO Lazy.ByteString encodeContainer codec = encodeContainerWithSchema codec (untag @a schema) -- | Encode chunks of values into a container, using 16 random bytes for -- the synchronization markers. Blocks are compressed (or not) according -- to the given 'Codec' ('nullCodec' or 'deflateCodec').-encodeContainerWithSchema :: ToAvro a => Codec -> Schema -> [[a]] -> IO BL.ByteString+encodeContainerWithSchema :: ToAvro a => Codec -> Schema -> [[a]] -> IO Lazy.ByteString encodeContainerWithSchema codec sch xss = do sync <- Container.newSyncBytes return $ encodeContainerWithSync codec sch sync xss -- |Encode chunks of objects into a container, using the provided -- ByteString as the synchronization markers.-encodeContainerWithSync :: ToAvro a => Codec -> Schema -> BL.ByteString -> [[a]] -> BL.ByteString+encodeContainerWithSync :: ToAvro a => Codec -> Schema -> Lazy.ByteString -> [[a]] -> Lazy.ByteString encodeContainerWithSync = Container.packContainerValuesWithSync' toAvro {-# INLINE encodeContainerWithSync #-}
src/Data/Avro/Codec.hs view
@@ -12,11 +12,10 @@ import Codec.Compression.Zlib.Internal as Zlib import qualified Data.Binary.Get as G import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy as Lazy -- | Block decompression function for blocks of Avro.-type Decompress a = LBS.ByteString -> G.Get a -> Either String a+type Decompress a = Lazy.ByteString -> G.Get a -> Either String a -- | A `Codec` allows for compression/decompression of a block in an -- Avro container according to the Avro spec.@@ -33,7 +32,7 @@ , codecDecompress :: forall a. Decompress a -- | Compresses a lazy stream of bytes.- , codecCompress :: LBS.ByteString -> LBS.ByteString+ , codecCompress :: Lazy.ByteString -> Lazy.ByteString } -- | `nullCodec` specifies @null@ required by Avro spec.@@ -61,7 +60,7 @@ , codecCompress = deflateCompress } -deflateCompress :: LBS.ByteString -> LBS.ByteString+deflateCompress :: Lazy.ByteString -> Lazy.ByteString deflateCompress = Zlib.compress Zlib.rawFormat Zlib.defaultCompressParams @@ -69,12 +68,12 @@ -- | Internal type to help construct a lazy list of -- decompressed bytes interleaved with errors if any. data Chunk- = ChunkRest LBS.ByteString+ = ChunkRest Lazy.ByteString | ChunkBytes ByteString | ChunkError Zlib.DecompressError -deflateDecompress :: forall a. LBS.ByteString -> G.Get a -> Either String a+deflateDecompress :: forall a. Lazy.ByteString -> G.Get a -> Either String a deflateDecompress bytes parser = do let -- N.B. this list is lazily created which allows us to
src/Data/Avro/Deriving.hs view
@@ -7,10 +7,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{- HLINT ignore "Avoid lambda using `infix`" -}- -- | This module lets us derive Haskell types from an Avro schema that--- can be serialized/deserialzed to Avro.+-- can be serialized/deserialized to Avro. module Data.Avro.Deriving ( -- * Deriving options DeriveOptions(..)@@ -34,55 +32,45 @@ , deriveAvro' -- * Re-exporting a quasiquoter for raw string literals- , r+ , QQ.r ) where -import Control.Monad (join)-import Control.Monad.Identity (Identity)-import Data.Aeson (eitherDecode)-import qualified Data.Aeson as J-import Data.Avro hiding (decode, encode)-import Data.Avro.Encoding.ToAvro (ToAvro (..))-import Data.Avro.Internal.EncodeRaw (putI)-import Data.Avro.Schema.Schema as S-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.Char (isAlphaNum)+import Control.Monad ( join )+import Control.Monad.Identity ( Identity )++import Data.Aeson ( eitherDecode )+import Data.ByteString ( ByteString )+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy import qualified Data.Foldable as Foldable-import Data.Int-import Data.List.NonEmpty (NonEmpty ((:|)))-import qualified Data.List.NonEmpty as NE-import Data.Map (Map)-import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>))+import Data.Text (Text) import qualified Data.Text as Text-import Data.Time (Day, DiffTime, UTCTime)-import Data.UUID (UUID)-import Text.RawString.QQ (r)+import qualified Data.Vector as V+import Data.Char ( isAlphaNum )+import Data.Int ( Int32, Int64 )+import Data.Map ( Map )+import Data.Time ( Day, DiffTime, LocalTime, UTCTime )+import Data.UUID ( UUID ) -import qualified Data.Avro.Encoding.FromAvro as AV+import GHC.Generics ( Generic )+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax+import qualified Text.RawString.QQ as QQ -import GHC.Generics (Generic) -import Language.Haskell.TH as TH hiding (notStrict)-import Language.Haskell.TH.Lib as TH hiding (notStrict)-import Language.Haskell.TH.Syntax+import qualified Data.Avro.Encoding.FromAvro as AV+import Data.Avro.Encoding.ToAvro ( ToAvro(..) )+import Data.Avro.HasAvroSchema ( HasAvroSchema )+import qualified Data.Avro.HasAvroSchema+import Data.Avro.Internal.EncodeRaw ( putI )+import Data.Avro.Schema.Schema ( Schema, TypeName, Field )+import qualified Data.Avro.Schema.Schema as Schema+import Data.Avro.Deriving.Lift ()+import Data.Avro.Deriving.NormSchema+import Data.Avro.EitherN -import Data.Avro.Deriving.NormSchema-import Data.Avro.EitherN -import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Lazy.Char8 as LBSC8-import qualified Data.HashMap.Strict as HM-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Vector as V--import Data.Avro.Deriving.Lift ()- -- | How to treat Avro namespaces in the generated Haskell types. data NamespaceBehavior = IgnoreNamespaces@@ -103,7 +91,7 @@ -- @Com'example'Foo@. If @Foo@ had a field called @bar@, the -- generated Haskell record would have the field -- @com'example'FooBar@.- | Custom (T.Text -> [T.Text] -> T.Text)+ | Custom (Text -> [Text] -> Text) -- ^ Provide a custom mapping from the name of the Avro type and -- its namespace that will be used to generate Haskell types and -- fields.@@ -127,7 +115,7 @@ { -- | How to build field names for generated data types. The first -- argument is the type name to use as a prefix, rendered -- according to the 'namespaceBehavior' setting.- fieldNameBuilder :: Text -> Field -> T.Text+ fieldNameBuilder :: Text -> Field -> Text -- | Determines field representation of generated data types , fieldRepresentation :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)@@ -146,6 +134,7 @@ -- , namespaceBehavior = 'IgnoreNamespaces' -- } -- @+defaultDeriveOptions :: DeriveOptions defaultDeriveOptions = DeriveOptions { fieldNameBuilder = mkPrefixedFieldName , fieldRepresentation = mkLazyField@@ -160,9 +149,9 @@ -- @ -- Person { personFirstName :: Text } -- @-mkPrefixedFieldName :: Text -> Field -> T.Text+mkPrefixedFieldName :: Text -> Field -> Text mkPrefixedFieldName prefix fld =- sanitiseName $ updateFirst T.toLower prefix <> updateFirst T.toUpper (fldName fld)+ sanitiseName $ updateFirst Text.toLower prefix <> updateFirst Text.toUpper (Schema.fldName fld) -- | Marks any field as non-strict in the generated data types. mkLazyField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness)@@ -180,19 +169,19 @@ else (LazyField, NonUnpackedField) where unpackedness =- case S.fldType field of- S.Null -> NonUnpackedField- S.Boolean -> NonUnpackedField+ case Schema.fldType field of+ Schema.Null -> NonUnpackedField+ Schema.Boolean -> NonUnpackedField _ -> UnpackedField shouldStricten =- case S.fldType field of- S.Null -> True- S.Boolean -> True- S.Int _ -> True- S.Long _ -> True- S.Float -> True- S.Double -> True+ case Schema.fldType field of+ Schema.Null -> True+ Schema.Boolean -> True+ Schema.Int _ -> True+ Schema.Long _ -> True+ Schema.Float -> True+ Schema.Double -> True _ -> False -- | Generates a field name that matches the field name in schema@@ -206,7 +195,7 @@ -- @ -- You may want to enable 'DuplicateRecordFields' if you want to use this method. mkAsIsFieldName :: Text -> Field -> Text-mkAsIsFieldName _ = sanitiseName . updateFirst T.toLower . fldName+mkAsIsFieldName _ = sanitiseName . updateFirst Text.toLower . Schema.fldName -- | Derives Haskell types from the given Avro schema file. These -- Haskell types support both reading and writing to Avro.@@ -273,7 +262,7 @@ deriveAvro' = deriveAvroWithOptions' defaultDeriveOptions -- | Same as 'deriveAvro' but takes a ByteString rather than FilePath-deriveAvroFromByteString :: LBS.ByteString -> Q [Dec]+deriveAvroFromByteString :: Lazy.ByteString -> Q [Dec] deriveAvroFromByteString bs = case eitherDecode bs of Right schema -> deriveAvroWithOptions' defaultDeriveOptions schema Left err -> fail $ "Unable to generate Avro from bytestring: " <> err@@ -288,7 +277,7 @@ makeSchema :: FilePath -> Q Exp makeSchema p = readSchema p >>= lift -makeSchemaFromByteString :: LBS.ByteString -> Q Exp+makeSchemaFromByteString :: Lazy.ByteString -> Q Exp makeSchemaFromByteString bs = case eitherDecode @Schema bs of Right schema -> lift schema Left err -> fail $ "Unable to generate Avro Schema from bytestring: " <> err@@ -296,9 +285,8 @@ makeSchemaFrom :: FilePath -> Text -> Q Exp makeSchemaFrom p name = do s <- readSchema p-- case subdefinition s name of- Nothing -> fail $ "No such entity '" <> T.unpack name <> "' defined in " <> p+ case Schema.subdefinition s name of+ Nothing -> fail $ "No such entity '" <> Text.unpack name <> "' defined in " <> p Just ss -> lift ss readSchema :: FilePath -> Q Schema@@ -315,29 +303,29 @@ badValueNew v t = Left $ "Unexpected value for '" <> t <> "': " <> show v genFromValue :: NamespaceBehavior -> Schema -> Q [Dec]-genFromValue namespaceBehavior (S.Enum n _ _ _ ) =- [d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where+genFromValue namespaceBehavior (Schema.Enum n _ _ _ ) =+ [d| instance AV.FromAvro $(TH.conT $ mkDataTypeName namespaceBehavior n) where fromAvro (AV.Enum _ i _) = $([| pure . toEnum|]) i- fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value+ fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ Schema.renderFullname n)|] ) value |]-genFromValue namespaceBehavior (S.Record n _ _ fs) =- [d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where+genFromValue namespaceBehavior (Schema.Record n _ _ fs) =+ [d| instance AV.FromAvro $(TH.conT $ mkDataTypeName namespaceBehavior n) where fromAvro (AV.Record _ r) = $(genFromAvroNewFieldsExp (mkDataTypeName namespaceBehavior n) fs) r- fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value+ fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ Schema.renderFullname n)|] ) value |]-genFromValue namespaceBehavior (S.Fixed n _ s _) =- [d| instance AV.FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where+genFromValue namespaceBehavior (Schema.Fixed n _ s _) =+ [d| instance AV.FromAvro $(TH.conT $ mkDataTypeName namespaceBehavior n) where fromAvro (AV.Fixed _ v)- | BS.length v == s = pure $ $(conE (mkDataTypeName namespaceBehavior n)) v- fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ S.renderFullname n)|] ) value+ | Strict.length v == s = pure $ $(TH.conE (mkDataTypeName namespaceBehavior n)) v+ fromAvro value = $( [|\v -> badValueNew v $(mkTextLit $ Schema.renderFullname n)|] ) value |] genFromValue _ _ = pure [] genFromAvroNewFieldsExp :: Name -> [Field] -> Q Exp genFromAvroNewFieldsExp n xs = [| \r ->- $(let ctor = [| pure $(conE n) |]+ $(let ctor = [| pure $(TH.conE n) |] in foldl (\expr (i, _) -> [| $expr <*> AV.fromAvro (r V.! i) |]) ctor (zip [(0 :: Int)..] xs) ) |]@@ -346,14 +334,14 @@ genHasAvroSchema :: NamespaceBehavior -> Schema -> Q [Dec] genHasAvroSchema namespaceBehavior s = do- let sname = mkSchemaValueName namespaceBehavior (name s)+ let sname = mkSchemaValueName namespaceBehavior (Schema.name s) sdef <- schemaDef sname s idef <- hasAvroSchema sname pure (sdef <> idef) where hasAvroSchema sname =- [d| instance HasAvroSchema $(conT $ mkDataTypeName namespaceBehavior (name s)) where- schema = pure $(varE sname)+ [d| instance HasAvroSchema $(TH.conT $ mkDataTypeName namespaceBehavior (Schema.name s)) where+ schema = pure $(TH.varE sname) |] newNames :: String@@ -366,40 +354,40 @@ ------------------------- ToAvro ------------------------------------------------ genToAvro :: DeriveOptions -> Schema -> Q [Dec]-genToAvro opts s@(S.Enum n _ _ _) =+genToAvro opts (Schema.Enum n _ _ _) = encodeAvroInstance (mkSchemaValueName (namespaceBehavior opts) n) where- encodeAvroInstance sname =- [d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where+ encodeAvroInstance _ =+ [d| instance ToAvro $(TH.conT $ mkDataTypeName (namespaceBehavior opts) n) where toAvro = $([| \_ x -> putI (fromEnum x) |]) |] -genToAvro opts s@(S.Record n _ _ fs) =+genToAvro opts (Schema.Record n _ _ fs) = encodeAvroInstance (mkSchemaValueName (namespaceBehavior opts) n) where encodeAvroInstance sname =- [d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where+ [d| instance ToAvro $(TH.conT $ mkDataTypeName (namespaceBehavior opts) n) where toAvro = $(encodeAvroFieldsExp sname) |]- encodeAvroFieldsExp sname = do+ encodeAvroFieldsExp _ = do names <- newNames "p_" (length fs)- wn <- varP <$> newName "_"- let con = conP (mkDataTypeName (namespaceBehavior opts) n) (varP <$> names)- lamE [wn, con]- [| mconcat $( let build (fld, n) = [| toAvro (fldType fld) $(varE n) |]- in listE $ build <$> zip fs names+ wn <- TH.varP <$> newName "_"+ let con = TH.conP (mkDataTypeName (namespaceBehavior opts) n) (TH.varP <$> names)+ TH.lamE [wn, con]+ [| mconcat $( let build (fld, nm) = [| toAvro (Schema.fldType fld) $(TH.varE nm) |]+ in TH.listE $ build <$> zip fs names ) |] -genToAvro opts s@(S.Fixed n _ _ _) =+genToAvro opts (Schema.Fixed n _ _ _) = encodeAvroInstance (mkSchemaValueName (namespaceBehavior opts) n) where encodeAvroInstance sname =- [d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where+ [d| instance ToAvro $(TH.conT $ mkDataTypeName (namespaceBehavior opts) n) where toAvro = $(do x <- newName "x" wc <- newName "_"- lamE [varP wc, conP (mkDataTypeName (namespaceBehavior opts) n) [varP x]] [| toAvro $(varE sname) $(varE x) |])+ TH.lamE [TH.varP wc, TH.conP (mkDataTypeName (namespaceBehavior opts) n) [TH.varP x]] [| toAvro $(TH.varE sname) $(TH.varE x) |]) |] genToAvro _ _ = pure [] @@ -421,73 +409,98 @@ sn _ d = d genType :: DeriveOptions -> Schema -> Q [Dec]-genType opts (S.Record n _ _ fs) = do+genType opts (Schema.Record n _ _ fs) = do flds <- traverse (mkField opts n) fs let dname = mkDataTypeName (namespaceBehavior opts) n sequenceA [genDataType dname flds]-genType opts (S.Enum n _ _ vs) = do+genType opts (Schema.Enum n _ _ vs) = do let dname = mkDataTypeName (namespaceBehavior opts) n sequenceA [genEnum dname (mkAdtCtorName (namespaceBehavior opts) n <$> V.toList vs)]-genType opts (S.Fixed n _ s _) = do+genType opts (Schema.Fixed n _ _ _) = do let dname = mkDataTypeName (namespaceBehavior opts) n sequenceA [genNewtype dname] genType _ _ = pure [] -mkFieldTypeName :: NamespaceBehavior -> S.Schema -> Q TH.Type+mkFieldTypeName :: NamespaceBehavior -> Schema -> Q TH.Type mkFieldTypeName namespaceBehavior = \case- S.Null -> [t| () |]- S.Boolean -> [t| Bool |]- S.Long (Just (DecimalL (Decimal p s)))- -> [t| Decimal $(litT $ numTyLit p) $(litT $ numTyLit s) |]- S.Long (Just TimeMicros)- -> [t| DiffTime |]- S.Long (Just TimestampMicros)- -> [t| UTCTime |]- S.Long (Just TimestampMillis)- -> [t| UTCTime |]- S.Long _ -> [t| Int64 |]- S.Int (Just Date) -> [t| Day |]- S.Int (Just TimeMillis)- -> [t| DiffTime |]- S.Int _ -> [t| Int32 |]- S.Float -> [t| Float |]- S.Double -> [t| Double |]- S.Bytes _ -> [t| ByteString |]- S.String Nothing -> [t| Text |]- S.String (Just UUID) -> [t| UUID |]- S.Union branches -> union (Foldable.toList branches)- S.Record n _ _ _ -> [t| $(conT $ mkDataTypeName namespaceBehavior n) |]- S.Map x -> [t| Map Text $(go x) |]- S.Array x -> [t| [$(go x)] |]- S.NamedType n -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]- S.Fixed n _ _ _ -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]- S.Enum n _ _ _ -> [t| $(conT $ mkDataTypeName namespaceBehavior n)|]- where go = mkFieldTypeName namespaceBehavior- union = \case- [] ->- error "Empty union types are not supported"- [x] -> [t| Identity $(go x) |]- [Null, x] -> [t| Maybe $(go x) |]- [x, Null] -> [t| Maybe $(go x) |]- [x, y] -> [t| Either $(go x) $(go y) |]- [a, b, c] -> [t| Either3 $(go a) $(go b) $(go c) |]- [a, b, c, d] -> [t| Either4 $(go a) $(go b) $(go c) $(go d) |]- [a, b, c, d, e] -> [t| Either5 $(go a) $(go b) $(go c) $(go d) $(go e) |]- [a, b, c, d, e, f] -> [t| Either6 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) |]- [a, b, c, d, e, f, g] -> [t| Either7 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g)|]- [a, b, c, d, e, f, g, h] -> [t| Either8 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h)|]- [a, b, c, d, e, f, g, h, i] -> [t| Either9 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h) $(go i)|]- [a, b, c, d, e, f, g, h, i, j] -> [t| Either10 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h) $(go i) $(go j)|]- ls ->- error $ "Unions with more than 10 elements are not yet supported: Union has " <> (show . length) ls <> " elements"+ Schema.Null -> [t| () |]+ Schema.Boolean -> [t| Bool |] + Schema.Long (Just (Schema.DecimalL (Schema.Decimal p s)))+ -> [t| Schema.Decimal $(TH.litT $ TH.numTyLit p) $(TH.litT $ TH.numTyLit s) |]+ Schema.Long (Just Schema.TimeMicros)+ -> [t| DiffTime |]+ Schema.Long (Just Schema.TimestampMicros)+ -> [t| UTCTime |]+ Schema.Long (Just Schema.TimestampMillis)+ -> [t| UTCTime |]+ Schema.Long (Just Schema.LocalTimestampMillis)+ -> [t| LocalTime |]+ Schema.Long (Just Schema.LocalTimestampMicros)+ -> [t| LocalTime |]+ Schema.Long Nothing+ -> [t| Int64 |]++ Schema.Int (Just Schema.Date)+ -> [t| Day |]+ Schema.Int (Just Schema.TimeMillis)+ -> [t| DiffTime |]+ Schema.Int _+ -> [t| Int32 |]+ Schema.Float+ -> [t| Float |]+ Schema.Double+ -> [t| Double |]+ Schema.Bytes _+ -> [t| ByteString |]+ Schema.String Nothing+ -> [t| Text |]+ Schema.String (Just Schema.UUID) ->+ [t| UUID |]+ Schema.Union branches+ -> union (Foldable.toList branches)+ Schema.Record n _ _ _+ -> [t| $(TH.conT $ mkDataTypeName namespaceBehavior n) |]+ Schema.Map x+ -> [t| Map Text $(go x) |]+ Schema.Array x+ -> [t| [$(go x)] |]+ Schema.NamedType n+ -> [t| $(TH.conT $ mkDataTypeName namespaceBehavior n)|]+ Schema.Fixed n _ _ _+ -> [t| $(TH.conT $ mkDataTypeName namespaceBehavior n)|]+ Schema.Enum n _ _ _+ -> [t| $(TH.conT $ mkDataTypeName namespaceBehavior n)|]+ where+ go = mkFieldTypeName namespaceBehavior+ union = \case+ []+ -> error "Empty union types are not supported"+ [x]+ -> [t| Identity $(go x) |]+ [Schema.Null, x]+ -> [t| Maybe $(go x) |]+ [x, Schema.Null]+ -> [t| Maybe $(go x) |]+ [x, y] -> [t| Either $(go x) $(go y) |]+ [a, b, c] -> [t| Either3 $(go a) $(go b) $(go c) |]+ [a, b, c, d] -> [t| Either4 $(go a) $(go b) $(go c) $(go d) |]+ [a, b, c, d, e] -> [t| Either5 $(go a) $(go b) $(go c) $(go d) $(go e) |]+ [a, b, c, d, e, f] -> [t| Either6 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) |]+ [a, b, c, d, e, f, g] -> [t| Either7 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g)|]+ [a, b, c, d, e, f, g, h] -> [t| Either8 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h)|]+ [a, b, c, d, e, f, g, h, i] -> [t| Either9 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h) $(go i)|]+ [a, b, c, d, e, f, g, h, i, j] -> [t| Either10 $(go a) $(go b) $(go c) $(go d) $(go e) $(go f) $(go g) $(go h) $(go i) $(go j)|]+ ls ->+ error $ "Unions with more than 10 elements are not yet supported: Union has " <> (show . length) ls <> " elements"+ updateFirst :: (Text -> Text) -> Text -> Text updateFirst f t =- let (l, ls) = T.splitAt 1 t+ let (l, ls) = Text.splitAt 1 t in f l <> ls decodeSchema :: FilePath -> IO (Either String Schema)-decodeSchema p = eitherDecode <$> LBS.readFile p+decodeSchema p = eitherDecode <$> Lazy.readFile p mkAdtCtorName :: NamespaceBehavior -> TypeName -> Text -> Name mkAdtCtorName namespaceBehavior prefix nm =@@ -499,7 +512,7 @@ sanitiseName :: Text -> Text sanitiseName = let valid c = isAlphaNum c || c == '\'' || c == '_'- in T.concat . T.split (not . valid)+ in Text.concat . Text.split (not . valid) -- | Renders a fully qualified Avro name to a valid Haskell -- identifier. This does not change capitalization—make sure to@@ -520,7 +533,7 @@ -- ^ The name to transform into a valid Haskell -- identifier. -> Text-renderName namespaceBehavior (TN name namespace) = case namespaceBehavior of+renderName namespaceBehavior (Schema.TN name namespace) = case namespaceBehavior of HandleNamespaces -> Text.intercalate "'" $ namespace <> [name] IgnoreNamespaces -> name Custom f -> f name namespace@@ -534,11 +547,11 @@ mkDataTypeName' :: Text -> Name mkDataTypeName' =- mkTextName . sanitiseName . updateFirst T.toUpper . T.takeWhileEnd (/='.')+ mkTextName . sanitiseName . updateFirst Text.toUpper . Text.takeWhileEnd (/='.') mkField :: DeriveOptions -> TypeName -> Field -> Q VarStrictType mkField opts typeName field = do- ftype <- mkFieldTypeName (namespaceBehavior opts) (fldType field)+ ftype <- mkFieldTypeName (namespaceBehavior opts) (Schema.fldType field) let prefix = renderName (namespaceBehavior opts) typeName fName = mkTextName $ fieldNameBuilder opts prefix field (fieldStrictness, fieldUnpackedness) =@@ -618,10 +631,7 @@ #endif mkTextName :: Text -> Name-mkTextName = mkName . T.unpack--mkLit :: String -> ExpQ-mkLit = litE . StringL+mkTextName = mkName . Text.unpack -mkTextLit :: Text -> ExpQ-mkTextLit = litE . StringL . T.unpack+mkTextLit :: Text -> TH.ExpQ+mkTextLit = TH.litE . StringL . Text.unpack
src/Data/Avro/Deriving/Lift.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}@@ -8,26 +7,9 @@ module Data.Avro.Deriving.Lift where import qualified Data.Avro.Schema.Schema as Schema-import qualified Data.ByteString as ByteString-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Text as Text-import qualified Data.Vector as Vector-import Language.Haskell.TH.Syntax (Lift (..)) -instance Lift ByteString.ByteString where- lift b = [| ByteString.pack $(lift $ ByteString.unpack b) |]--#if MIN_VERSION_text(1,2,4)-#else-instance Lift Text.Text where- lift t = [| Text.pack $(lift $ Text.unpack t) |]-#endif--instance Lift a => Lift (Vector.Vector a) where- lift v = [| Vector.fromList $(lift $ Vector.toList v) |]--instance (Lift k, Lift v) => Lift (HashMap.HashMap k v) where- lift m = [| HashMap.fromList $(lift $ HashMap.toList m) |]+import Language.Haskell.TH.Syntax (Lift (..))+import Instances.TH.Lift () deriving instance Lift Schema.DefaultValue deriving instance Lift Schema.Field
src/Data/Avro/Deriving/NormSchema.hs view
@@ -6,15 +6,7 @@ import Control.Monad.State.Strict import Data.Avro.Schema.Schema import qualified Data.Foldable as Foldable-import qualified Data.List as L-import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.Map.Strict as M-import Data.Maybe (catMaybes, fromMaybe)-import Data.Semigroup ((<>))-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Vector as V -- | Extracts all the records from the schema (flattens the schema) -- Named types get resolved when needed to include at least one "inlined"@@ -23,10 +15,10 @@ -- namespaces (including inlined into full names) will be ignored -- during names resolution. extractDerivables :: Schema -> [Schema]-extractDerivables s = flip evalState state . normSchema . snd <$> rawRecs+extractDerivables s = flip evalState initial . normSchema . snd <$> rawRecs where rawRecs = getTypes s- state = M.fromList rawRecs+ initial = M.fromList rawRecs getTypes :: Schema -> [(TypeName, Schema)] getTypes rec = case rec of@@ -49,7 +41,9 @@ -- use the looked up schema (which might be a full record) and replace -- it in the state with NamedType for future resolves -- because only one full definition per schema is needed- modify' (M.insert tn t) >> pure rs+ modify' (M.insert tn t) >> case rs of+ NamedType _ -> pure rs -- If we get a reference, the schema was already normalised.+ _ -> normSchema rs -- Otherwise, normalise the schema before inlining. -- NamedType but no corresponding record?! Baaad! Nothing ->@@ -58,12 +52,15 @@ Array s -> Array <$> normSchema s Map s -> Map <$> normSchema s Union l -> Union <$> traverse normSchema l- r@Record{name = tn} -> do- modify' (M.insert tn (NamedType tn))+ Record { name } -> do+ modify' (M.insert name (NamedType name)) flds <- mapM (\fld -> setType fld <$> normSchema (fldType fld)) (fields r) pure $ r { fields = flds }- r@Fixed{name = tn} -> do- modify' (M.insert tn (NamedType tn))+ Fixed { name } -> do+ modify' (M.insert name (NamedType name))+ pure r+ Enum { name } -> do+ modify' (M.insert name (NamedType name)) pure r s -> pure s where
src/Data/Avro/EitherN.hs view
@@ -443,6 +443,7 @@ fromAvro (AV.Union _ 1 b) = E3_2 <$> fromAvro b fromAvro (AV.Union _ 2 c) = E3_3 <$> fromAvro c fromAvro (AV.Union _ n _) = Left ("Unable to decode Either3 from a position #" <> show n)+ fromAvro n = Left ("Unable to decode Either3 from value " <> AV.describeValue n) instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d) => FromAvro (Either4 a b c d) where fromAvro (AV.Union _ 0 a) = E4_1 <$> fromAvro a@@ -450,6 +451,7 @@ fromAvro (AV.Union _ 2 c) = E4_3 <$> fromAvro c fromAvro (AV.Union _ 3 d) = E4_4 <$> fromAvro d fromAvro (AV.Union _ n _) = Left ("Unable to decode Either4 from a position #" <> show n)+ fromAvro n = Left ("Unable to decode Either4 from value " <> AV.describeValue n) instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d, FromAvro e) => FromAvro (Either5 a b c d e) where fromAvro (AV.Union _ 0 a) = E5_1 <$> fromAvro a@@ -458,6 +460,7 @@ fromAvro (AV.Union _ 3 d) = E5_4 <$> fromAvro d fromAvro (AV.Union _ 4 e) = E5_5 <$> fromAvro e fromAvro (AV.Union _ n _) = Left ("Unable to decode Either5 from a position #" <> show n)+ fromAvro n = Left ("Unable to decode Either5 from value " <> AV.describeValue n) instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d, FromAvro e, FromAvro f) => FromAvro (Either6 a b c d e f) where fromAvro (AV.Union _ 0 a) = E6_1 <$> fromAvro a@@ -467,6 +470,7 @@ fromAvro (AV.Union _ 4 e) = E6_5 <$> fromAvro e fromAvro (AV.Union _ 5 f) = E6_6 <$> fromAvro f fromAvro (AV.Union _ n _) = Left ("Unable to decode Either6 from a position #" <> show n)+ fromAvro n = Left ("Unable to decode Either6 from value " <> AV.describeValue n) instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d, FromAvro e, FromAvro f, FromAvro g) => FromAvro (Either7 a b c d e f g) where fromAvro (AV.Union _ 0 a) = E7_1 <$> fromAvro a@@ -477,6 +481,7 @@ fromAvro (AV.Union _ 5 f) = E7_6 <$> fromAvro f fromAvro (AV.Union _ 6 g) = E7_7 <$> fromAvro g fromAvro (AV.Union _ n _) = Left ("Unable to decode Either7 from a position #" <> show n)+ fromAvro n = Left ("Unable to decode Either7 from value " <> AV.describeValue n) instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d, FromAvro e, FromAvro f, FromAvro g, FromAvro h) => FromAvro (Either8 a b c d e f g h) where fromAvro (AV.Union _ 0 a) = E8_1 <$> fromAvro a@@ -488,6 +493,7 @@ fromAvro (AV.Union _ 6 g) = E8_7 <$> fromAvro g fromAvro (AV.Union _ 7 h) = E8_8 <$> fromAvro h fromAvro (AV.Union _ n _) = Left ("Unable to decode Either8 from a position #" <> show n)+ fromAvro n = Left ("Unable to decode Either8 from value " <> AV.describeValue n) instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d, FromAvro e, FromAvro f, FromAvro g, FromAvro h, FromAvro i) => FromAvro (Either9 a b c d e f g h i) where fromAvro (AV.Union _ 0 a) = E9_1 <$> fromAvro a@@ -500,6 +506,7 @@ fromAvro (AV.Union _ 7 h) = E9_8 <$> fromAvro h fromAvro (AV.Union _ 8 i) = E9_9 <$> fromAvro i fromAvro (AV.Union _ n _) = Left ("Unable to decode Either9 from a position #" <> show n)+ fromAvro n = Left ("Unable to decode Either9 from value " <> AV.describeValue n) instance (FromAvro a, FromAvro b, FromAvro c, FromAvro d, FromAvro e, FromAvro f, FromAvro g, FromAvro h, FromAvro i, FromAvro j) => FromAvro (Either10 a b c d e f g h i j) where fromAvro (AV.Union _ 0 a) = E10_1 <$> fromAvro a@@ -513,6 +520,7 @@ fromAvro (AV.Union _ 8 i) = E10_9 <$> fromAvro i fromAvro (AV.Union _ 9 j) = E10_10 <$> fromAvro j fromAvro (AV.Union _ n _) = Left ("Unable to decode Either10 from a position #" <> show n)+ fromAvro n = Left ("Unable to decode Either10 from value " <> AV.describeValue n) putIndexedValue :: ToAvro a => Int -> V.Vector Schema -> a -> Builder putIndexedValue i opts x = putI i <> toAvro (V.unsafeIndex opts i) x
src/Data/Avro/Encoding/FromAvro.hs view
@@ -3,40 +3,34 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StrictData #-}-{-# LANGUAGE TupleSections #-} module Data.Avro.Encoding.FromAvro ( FromAvro(..) -- ** For internal use , Value(..) , getValue++, describeValue ) where import Control.DeepSeq (NFData)-import Control.Monad (forM, replicateM)+import Control.Monad (forM, replicateM, void, when) import Control.Monad.Identity (Identity (..))-import Control.Monad.ST (ST)-import qualified Data.Aeson as A import qualified Data.Avro.Internal.Get as Get import Data.Avro.Internal.Time import Data.Avro.Schema.Decimal as D import Data.Avro.Schema.ReadSchema (ReadSchema) import qualified Data.Avro.Schema.ReadSchema as ReadSchema import qualified Data.Avro.Schema.Schema as Schema-import Data.Binary.Get (Get, getByteString, runGetOrFail)+import Data.Binary.Get (Get, getByteString) import qualified Data.ByteString as BS-import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import qualified Data.Char as Char+import Data.Foldable (traverse_) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int-import Data.List.NonEmpty (NonEmpty)-import Data.Foldable (traverse_) import qualified Data.Map as Map import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text as T import qualified Data.Text.Encoding as Text import qualified Data.Time as Time import qualified Data.UUID as UUID@@ -76,20 +70,20 @@ -- (i.e. do not print values) describeValue :: Value -> String describeValue = \case- Null -> "Null"- Boolean b -> "Boolean"- Int s _ -> "Int (" <> show s <> ")"- Long s _ -> "Long (" <> show s <> ")"- Float s _ -> "Float (" <> show s <> ")"- Double s _ -> "Double (" <> show s <> ")"- Bytes s _ -> "Bytes (" <> show s <> ")"- String s _ -> "String (" <> show s <> ")"- Union s ix _ -> "Union (position = " <> show ix <> ", schema = " <> show s <> ")"- Fixed s _ -> "Fixed (" <> show s <> ")"- Enum s ix _ -> "Enum (position = " <> show ix <> ", schema =" <> show s <> ")"- Array vs -> "Array (length = " <> show (V.length vs) <> ")"- Map vs -> "Map (length = " <> show (HashMap.size vs) <> ")"- Record s vs -> "Record (name = " <> show (ReadSchema.name s) <> " fieldsNum = " <> show (V.length vs) <> ")"+ Null -> "Null"+ Boolean _ -> "Boolean"+ Int s _ -> "Int (" <> show s <> ")"+ Long s _ -> "Long (" <> show s <> ")"+ Float s _ -> "Float (" <> show s <> ")"+ Double s _ -> "Double (" <> show s <> ")"+ Bytes s _ -> "Bytes (" <> show s <> ")"+ String s _ -> "String (" <> show s <> ")"+ Union s ix _ -> "Union (position = " <> show ix <> ", schema = " <> show s <> ")"+ Fixed s _ -> "Fixed (" <> show s <> ")"+ Enum s ix _ -> "Enum (position = " <> show ix <> ", schema =" <> show s <> ")"+ Array vs -> "Array (length = " <> show (V.length vs) <> ")"+ Map vs -> "Map (length = " <> show (HashMap.size vs) <> ")"+ Record s vs -> "Record (name = " <> show (ReadSchema.name s) <> " fieldsNum = " <> show (V.length vs) <> ")" -------------------------------------------------------------------------- @@ -194,6 +188,14 @@ fromAvro x = Left ("Unable to decode UTCTime from: " <> show (describeValue x)) {-# INLINE fromAvro #-} +instance FromAvro Time.LocalTime where+ fromAvro (Long (ReadSchema.Long _ (Just ReadSchema.LocalTimestampMicros)) n) =+ Right $ microsToLocalTime (toInteger n)+ fromAvro (Long (ReadSchema.Long _ (Just ReadSchema.LocalTimestampMillis)) n) =+ Right $ millisToLocalTime (toInteger n)+ fromAvro x = Left ("Unable to decode LocalTime from: " <> show (describeValue x))+ {-# INLINE fromAvro #-}+ instance FromAvro a => FromAvro [a] where fromAvro (Array vec) = mapM fromAvro $ V.toList vec fromAvro x = Left ("Unable to decode Array from: " <> show (describeValue x))@@ -298,21 +300,33 @@ v <- getField env t pure $ Union sch ix v ++-- | Read a Map from blocks of KV pairs getKVBlocks :: HashMap Schema.TypeName ReadSchema -> ReadSchema -> Get [[(Text, Value)]] getKVBlocks env t = do- blockLength <- abs <$> Get.getLong- if blockLength == 0- then return []- else do vs <- replicateM (fromIntegral blockLength) ((,) <$> Get.getString <*> getField env t)- (vs:) <$> getKVBlocks env t+ lengthIndicator <- Get.getLong+ if lengthIndicator == 0 then+ return []+ else do+ -- When the block's count is negative, its absolute value is used, and the count is followed immediately by a+ -- long block size indicating the number of bytes in the block.+ when (lengthIndicator < 0) $ void Get.getLong -- number of bytes in block (ignored)+ let blockLength = abs lengthIndicator+ vs <- replicateM (fromIntegral blockLength) ((,) <$> Get.getString <*> getField env t)+ (vs:) <$> getKVBlocks env t {-# INLINE getKVBlocks #-} +-- | Read an array from blocks. getBlocksOf :: HashMap Schema.TypeName ReadSchema -> ReadSchema -> Get [[Value]] getBlocksOf env t = do- blockLength <- abs <$> Get.getLong- if blockLength == 0- then return []+ lengthIndicator <- Get.getLong+ if lengthIndicator == 0 then+ return [] else do+ -- When the block's count is negative, its absolute value is used, and the count is followed immediately by a+ -- long block size indicating the number of bytes in the block.+ when (lengthIndicator < 0) $ void Get.getLong -- number of bytes in block (ignored)+ let blockLength = abs lengthIndicator vs <- replicateM (fromIntegral blockLength) (getField env t) (vs:) <$> getBlocksOf env t @@ -321,7 +335,7 @@ moos <- fmap concat . forM fs $ \f -> case ReadSchema.fldStatus f of ReadSchema.Ignored -> [] <$ getField env (ReadSchema.fldType f)- ReadSchema.AsIs i -> (\f -> [(i,f)]) <$> getField env (ReadSchema.fldType f)+ ReadSchema.AsIs i -> (\fld -> [(i,fld)]) <$> getField env (ReadSchema.fldType f) ReadSchema.Defaulted i v -> pure [(i, convertValue v)] --undefined return $ V.create $ do
src/Data/Avro/Encoding/ToAvro.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}@@ -6,8 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Data.Avro.Encoding.ToAvro-where+module Data.Avro.Encoding.ToAvro where import Control.Monad.Identity (Identity (..)) import qualified Data.Array as Ar@@ -28,10 +28,11 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import Data.Text (Text)-import qualified Data.Text as T import qualified Data.Text.Encoding as T+#if MIN_VERSION_text(2,0,0)+import qualified Data.Text.Foreign as T+#endif import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Time as Time import qualified Data.UUID as UUID import qualified Data.Vector as V@@ -48,7 +49,7 @@ record :: Schema -> [(Text, Encoder)] -> Builder record (S.Record _ _ _ fs) vs =- foldMap (mapField provided) fs+ foldMap (mapField provided) fs where provided :: HashMap Text Encoder provided = HashMap.fromList vs@@ -61,6 +62,8 @@ mapField :: HashMap Text Encoder -> S.Field -> Builder mapField env fld = maybe (failField fld) (flip runEncoder (S.fldType fld)) (HashMap.lookup (S.fldName fld) env)+record _ _ =+ error "Error in Schema passed to record. It was not of type Record." -- | Describes how to encode Haskell data types into Avro bytes class ToAvro a where@@ -153,12 +156,21 @@ toAvro s@(S.Long (Just S.TimestampMicros)) = toAvro @Int64 s . fromIntegral . diffTimeToMicros toAvro s@(S.Long (Just S.TimestampMillis)) = toAvro @Int64 s . fromIntegral . diffTimeToMillis toAvro s@(S.Int (Just S.TimeMillis)) = toAvro @Int32 s . fromIntegral . diffTimeToMillis- toAvro s = error ("Unble to decode DiffTime from " <> show s)+ toAvro s = error ("Unble to encode DiffTime as " <> show s) instance ToAvro Time.UTCTime where toAvro s@(S.Long (Just S.TimestampMicros)) = toAvro @Int64 s . fromIntegral . utcTimeToMicros toAvro s@(S.Long (Just S.TimestampMillis)) = toAvro @Int64 s . fromIntegral . utcTimeToMillis+ toAvro s = error ("Unable to encode UTCTime as " <> show s) +instance ToAvro Time.LocalTime where+ toAvro s@(S.Long (Just S.LocalTimestampMicros)) =+ toAvro @Int64 s . fromIntegral . localTimeToMicros+ toAvro s@(S.Long (Just S.LocalTimestampMillis)) =+ toAvro @Int64 s . fromIntegral . localTimeToMillis+ toAvro s =+ error ("Unable to encode LocalTime as " <> show s)+ instance ToAvro B.ByteString where toAvro s bs = case s of (S.Bytes _) -> encodeRaw (B.length bs) <> byteString bs@@ -174,13 +186,23 @@ instance ToAvro Text where toAvro s v =+#if MIN_VERSION_text(2,0,0) let+ res =+ encodeRaw @Int64 (fromIntegral (T.lengthWord8 v)) <> T.encodeUtf8Builder v+ in case s of+ (S.Bytes _) -> res+ (S.String _) -> res+ _ -> error ("Unable to encode Text as: " <> show s)+#else+ let bs = T.encodeUtf8 v res = encodeRaw (B.length bs) <> byteString bs in case s of (S.Bytes _) -> res (S.String _) -> res _ -> error ("Unable to encode Text as: " <> show s)+#endif {-# INLINE toAvro #-} instance ToAvro TL.Text where@@ -228,7 +250,7 @@ toAvro s _ = error ("Unable to encode Maybe as " <> show s) instance (ToAvro a) => ToAvro (Identity a) where- toAvro (S.Union opts) e@(Identity a) =+ toAvro (S.Union opts) (Identity a) = if V.length opts == 1 then putI 0 <> toAvro (V.unsafeIndex opts 0) a else error ("Unable to encode Identity as a single-value union: " <> show opts)
src/Data/Avro/HasAvroSchema.hs view
@@ -8,9 +8,8 @@ import qualified Data.Array as Ar import Data.Avro.Schema.Decimal as D import Data.Avro.Schema.Schema as S-import qualified Data.ByteString as B-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy import qualified Data.HashMap.Strict as HashMap import Data.Int import Data.Ix (Ix)@@ -81,10 +80,10 @@ instance HasAvroSchema TL.Text where schema = Tagged S.String' -instance HasAvroSchema B.ByteString where+instance HasAvroSchema Strict.ByteString where schema = Tagged S.Bytes' -instance HasAvroSchema BL.ByteString where+instance HasAvroSchema Lazy.ByteString where schema = Tagged S.Bytes' instance (KnownNat p, KnownNat s) => HasAvroSchema (D.Decimal p s) where@@ -103,6 +102,9 @@ instance HasAvroSchema Time.UTCTime where schema = Tagged $ S.Long (Just TimestampMicros)++instance HasAvroSchema Time.LocalTime where+ schema = Tagged $ S.Long (Just LocalTimestampMicros) instance (HasAvroSchema a) => HasAvroSchema (Identity a) where schema = Tagged $ S.Union $ V.fromListN 1 [untag @a schema]
src/Data/Avro/Internal/Container.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -24,11 +25,9 @@ import Data.ByteString.Builder (Builder, lazyByteString, toLazyByteString) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC-import Data.Either (isRight) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int (Int32, Int64)-import Data.List (foldl', unfoldr) import qualified Data.Map.Strict as Map import Data.Text (Text) import System.Random.TF.Init (initTFGen)@@ -94,51 +93,75 @@ decodeRawBlocks :: BL.ByteString -> Either String (Schema, [Either String (Int, BL.ByteString)]) decodeRawBlocks bs = case Get.runGetOrFail getContainerHeader bs of- Left (bs', _, err) -> Left err- Right (bs', _, ContainerHeader {..}) ->- let blocks = allBlocks syncBytes decompress bs'+ Left (_, _, err) -> Left err+ Right (bs', _, containerHeader@ContainerHeader {..}) ->+ let blocks = allBlocks containerHeader bs' in Right (containedSchema, blocks) where- allBlocks sync decompress bytes =- flip unfoldr (Just bytes) $ \case- Just rest -> next sync decompress rest- Nothing -> Nothing+ allBlocks containerHeader bytes =+ foldrBlocks (\x -> (Right x :)) (\err -> [Left err]) [] bytes+ (decodeRawBlocksIncremental containerHeader) - next syncBytes decompress bytes =- case getNextBlock syncBytes decompress bytes of- Right (Just (numObj, block, rest)) -> Just (Right (numObj, block), Just rest)- Right Nothing -> Nothing- Left err -> Just (Left err, Nothing)+data Blocks a+ = Block+ a+ (Blocks a)+ | More+ (ByteString -> Blocks a) -- ^ Feed more bytes. Pass the empty ByteString to+ -- signal end of input.+ | Error+ String -- ^ Error message+ ByteString -- ^ Leftover bytes+ | Done+ ByteString -- ^ Leftover bytes+ deriving (Functor) -getNextBlock :: BL.ByteString- -> Decompress BL.ByteString- -> BL.ByteString- -> Either String (Maybe (Int, BL.ByteString, BL.ByteString))-getNextBlock sync decompress bs =- if BL.null bs- then Right Nothing- else case Get.runGetOrFail (getRawBlock decompress) bs of- Left (bs', _, err) -> Left err- Right (bs', _, (nrObj, bytes)) ->- case checkMarker sync bs' of- Left err -> Left err- Right rest -> Right $ Just (nrObj, bytes, rest)+-- | Feeds a 'BL.ByteString' to the 'Blocks' until exhausted.+-- Consumes the 'BL.ByteString' lazily.+foldrBlocks :: (a -> b -> b) -> (String -> b) -> b -> BL.ByteString -> Blocks a -> b+foldrBlocks block err done input = go (BL.toChunks input) where- getRawBlock :: Decompress BL.ByteString -> Get (Int, BL.ByteString)- getRawBlock decompress = do- nrObj <- AGet.getLong >>= AGet.sFromIntegral- nrBytes <- AGet.getLong+ go chunks (Block a rest) = block a (go chunks rest)+ go [] (More cont) = go [] (cont "")+ go (c:cx) (More cont) = go cx (cont c)+ go _ (Error message _) = err message+ go _ (Done _) = done++decodeRawBlocksIncremental :: ContainerHeader -> Blocks (Int, BL.ByteString)+decodeRawBlocksIncremental ContainerHeader{..} = initial+ where+ initialDecoder =+ Get.runGetIncremental getRawBlock++ initial = More $ \input ->+ case input of+ "" -> Done ""+ _ -> go (Get.pushChunk initialDecoder input)++ go decoder = case decoder of+ Get.Done rest _ !block ->+ case rest of+ "" -> Block block initial+ _ -> Block block (go (Get.pushChunk initialDecoder rest))+ Get.Fail rest _ err ->+ Error err rest+ Get.Partial{} -> More $ \input ->+ case input of+ "" -> go (Get.pushEndOfInput decoder)+ _ -> go (Get.pushChunk decoder input)++ getRawBlock = do+ nrObj <- AGet.getLong >>= AGet.sFromIntegral+ nrBytes <- AGet.getLong compressed <- Get.getLazyByteString nrBytes bytes <- case decompress compressed Get.getRemainingLazyByteString of- Right x -> pure x+ Right x -> pure x Left err -> fail err- 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+ trailer <- Get.getLazyByteString nrSyncBytes+ if trailer /= syncBytes then+ fail "Invalid marker, does not match sync bytes."+ else+ pure (nrObj, bytes) -- | Splits container into a list of individual avro-encoded values. -- This version provides both encoded and decoded values.@@ -166,17 +189,30 @@ -> BL.ByteString -> Either String (Schema, [Either String a]) extractContainerValues deconflict f bs = do- (sch, blocks) <- decodeRawBlocks bs- readSchema <- deconflict sch- pure (sch, takeWhileInclusive isRight $ blocks >>= decodeBlock readSchema)+ case Get.runGetOrFail getContainerHeader bs of+ Left (_, _, err) -> Left err+ Right (rest, _, containerHeader) -> do+ (schema, blocks) <- extractContainerValuesIncremental deconflict f containerHeader+ let values = foldrBlocks (++) (\err -> [Left err]) [] rest blocks+ pure (schema, values)++extractContainerValuesIncremental+ :: (Schema -> Either String schema)+ -> (schema -> Get a)+ -> ContainerHeader+ -> Either String (Schema, Blocks [Either String a])+extractContainerValuesIncremental deconflict getValue containerHeader@ContainerHeader{..} = do+ readSchema <- deconflict containedSchema+ let blocks = decodeRawBlocksIncremental containerHeader+ pure (containedSchema, fmap (decodeBlock readSchema) blocks) where- decodeBlock _ (Left err) = undefined- decodeBlock sch (Right (nrObj, bytes)) = snd $ consumeN (fromIntegral nrObj) (decodeValue sch) bytes+ decodeBlock readSchema (nrObj, bytes) =+ snd $ consumeN (fromIntegral nrObj) (decodeValue readSchema) bytes - decodeValue sch bytes =- case Get.runGetOrFail (f sch) bytes of- Left (bs', _, err) -> (bs', Left err)- Right (bs', _, res) -> (bs', Right res)+ decodeValue readSchema bytes =+ case Get.runGetOrFail (getValue readSchema) bytes of+ Left (rest, _, err) -> (rest, Left err)+ Right (rest, _, value) -> (rest, Right value) -- | Packs a container from a given list of already encoded Avro values -- Each bytestring should represent exactly one one value serialised to Avro.
src/Data/Avro/Internal/Get.hs view
@@ -11,24 +11,16 @@ module Data.Avro.Internal.Get where -import qualified Codec.Compression.Zlib as Z-import Control.Monad (replicateM, when)+import Control.Monad (replicateM) import Data.Binary.Get (Get) 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.Int-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.Internal.DecodeRaw
src/Data/Avro/Internal/Time.hs view
@@ -3,10 +3,8 @@ -- Utility functions to work with times -import Data.Fixed (Fixed (..)) import Data.Maybe (fromJust) import Data.Time-import Data.Time.Clock import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #if MIN_VERSION_time(1,9,0) import Data.Time.Format.Internal@@ -50,3 +48,15 @@ millisToUTCTime :: Integer -> UTCTime millisToUTCTime x = addUTCTime (realToFrac $ picosecondsToDiffTime (x * 1000000000)) epoch++localTimeToMicros :: LocalTime -> Integer+localTimeToMicros = utcTimeToMicros . localTimeToUTC utc++localTimeToMillis :: LocalTime -> Integer+localTimeToMillis = utcTimeToMillis . localTimeToUTC utc++microsToLocalTime :: Integer -> LocalTime+microsToLocalTime = utcToLocalTime utc . microsToUTCTime++millisToLocalTime :: Integer -> LocalTime+millisToLocalTime = utcToLocalTime utc . millisToUTCTime
src/Data/Avro/JSON.hs view
@@ -60,6 +60,8 @@ module Data.Avro.JSON where import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM import Data.ByteString.Lazy (ByteString) import qualified Data.Foldable as Foldable import Data.HashMap.Strict ((!))@@ -99,12 +101,14 @@ | isBuiltIn name = name | otherwise = Schema.renderFullname $ Schema.parseFullname name branch =- head $ HashMap.keys obj+ K.toText $ head (KM.keys obj) names = HashMap.fromList [(Schema.typeName t, t) | t <- Foldable.toList schemas] in case HashMap.lookup (canonicalize branch) names of Just t -> do- nested <- parseAvroJSON union env t (obj ! branch)+ nested <- parseAvroJSON union env t $ case KM.lookup (K.fromText branch) obj of+ Just val -> val+ Nothing -> error "impossible" return (Schema.DUnion schemas t nested) Nothing -> fail ("Type '" <> Text.unpack branch <> "' not in union: " <> show schemas) union Schema.Union{} _ =
src/Data/Avro/Schema/Decimal.hs view
@@ -3,7 +3,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-module Data.Avro.Schema.Decimal where+module Data.Avro.Schema.Decimal+( Decimal+, fromUnderlyingValue+, underlyingValue )+where import qualified Data.BigDecimal as D import Data.Proxy@@ -13,11 +17,14 @@ = Decimal { unDecimal :: D.BigDecimal } deriving (Eq, Ord, Show, Read, Num, Fractional, Real) +intScale :: D.BigDecimal -> Integer+intScale = toInteger . D.scale+ fromUnderlyingValue :: forall p s. KnownNat s => Integer -> Decimal p s fromUnderlyingValue n- = Decimal $ D.BigDecimal n (natVal (Proxy :: Proxy s))+ = Decimal $ D.BigDecimal n (fromIntegral $ natVal (Proxy :: Proxy s)) underlyingValue :: forall s p. (KnownNat p, KnownNat s)@@ -25,9 +32,9 @@ underlyingValue (Decimal d) = let ss = natVal (Proxy :: Proxy s) pp = natVal (Proxy :: Proxy p)- new = if ss > D.getScale d- then D.BigDecimal (D.getValue d * 10 ^ (ss - D.getScale d)) ss- else D.roundBD d (D.halfUp ss)- in if D.precision new > pp+ new = if ss > intScale d+ then D.BigDecimal (D.value d * 10 ^ (ss - intScale d)) (fromIntegral ss)+ else D.roundBD d (D.halfUp (fromIntegral ss))+ in if D.precision new > fromIntegral pp then Nothing- else Just $ fromInteger $ D.getValue new+ else Just $ fromInteger $ D.value new
src/Data/Avro/Schema/Deconflict.hs view
@@ -6,26 +6,17 @@ import Control.Applicative ((<|>)) import Data.Avro.Schema.Schema as S import qualified Data.Foldable as Foldable-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.Maybe (isNothing)-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 import Data.Vector (Vector) import qualified Data.Vector as V import Data.Avro.Schema.ReadSchema (FieldStatus (..), ReadField, ReadSchema) import qualified Data.Avro.Schema.ReadSchema as Read -import Debug.Trace- -- | @deconflict writer reader@ will produce a schema that can decode -- with the writer's schema into the form specified by the reader's schema. --@@ -60,7 +51,7 @@ deconflict (S.Map w) (S.Map r) = Read.Map <$> deconflict w r deconflict w@S.Enum{} r@S.Enum{}- | name w == name r && symbols w `contains` symbols r = pure Read.Enum+ | name w == name r && symbols r `contains` symbols w = pure Read.Enum { Read.name = name r , Read.aliases = aliases w <> aliases r , Read.doc = doc r@@ -76,7 +67,7 @@ } deconflict w@S.Record {} r@S.Record {}- | name w == name r = do+ | name w == name r || name w `elem` aliases r = do fields' <- deconflictFields (fields w) (fields r) pure Read.Record { Read.name = name r@@ -138,5 +129,7 @@ findTypeV :: Schema -> Vector Schema -> Maybe (Int, Schema) findTypeV schema schemas = let tn = typeName schema- in case V.findIndex ((tn ==) . typeName) schemas of- Just ix -> Just (ix, V.unsafeIndex schemas ix)+ allNames typ =+ typeName typ : map renderFullname (typeAliases typ)+ in ((,) <$> id <*> V.unsafeIndex schemas) <$>+ V.findIndex ((tn `elem`) . allNames) schemas
src/Data/Avro/Schema/ReadSchema.hs view
@@ -21,10 +21,8 @@ import Control.DeepSeq (NFData) import Data.Avro.Schema.Schema (LogicalTypeBytes, LogicalTypeFixed, LogicalTypeInt, LogicalTypeLong, LogicalTypeString, Order, TypeName) import qualified Data.Avro.Schema.Schema as S-import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Text (Text)-import qualified Data.Text as T import qualified Data.Vector as V import GHC.Generics (Generic) @@ -199,4 +197,5 @@ f@Fixed{..} -> HashMap.fromList $ (name : aliases) `zip` repeat f Array{..} -> extractBindings item Map{..} -> extractBindings values+ FreeUnion {..} -> extractBindings ty _ -> HashMap.empty
src/Data/Avro/Schema/Schema.hs view
@@ -37,6 +37,7 @@ , validateSchema -- * Lower level utilities , typeName+ , typeAliases , buildTypeEnvironment , extractBindings @@ -63,29 +64,25 @@ import qualified Control.Monad.Fail as MF import Control.Monad.State.Strict -import Data.Aeson (FromJSON (..), ToJSON (..), object, (.!=), (.:), (.:!), (.:?), (.=))+import Data.Aeson (FromJSON (..), ToJSON (..), object, (.!=), (.:!), (.:), (.:?), (.=)) import qualified Data.Aeson as A+import qualified Data.Aeson.Key as A+import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (Parser, typeMismatch) import qualified Data.ByteString as B-import qualified Data.ByteString.Base16 as Base16 import qualified Data.Char as Char import Data.Function (on)-import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.Hashable import Data.Int-import qualified Data.IntMap as IM-import qualified Data.List as L import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes, fromMaybe, isJust)-import Data.Monoid (First (..)) import Data.Semigroup-import qualified Data.Set as S import Data.String import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding as T import qualified Data.Vector as V import Prelude as P @@ -147,9 +144,13 @@ } deriving (Ord, Show, Generic, NFData) +pattern Int' :: Schema pattern Int' = Int Nothing+pattern Long' :: Schema pattern Long' = Long Nothing+pattern Bytes' :: Schema pattern Bytes' = Bytes Nothing+pattern String' :: Schema pattern String' = String Nothing data Field = Field { fldName :: Text@@ -164,30 +165,140 @@ data Order = Ascending | Descending | Ignore deriving (Eq, Ord, Show, Generic, NFData) -data Decimal- = Decimal { precision :: Integer, scale :: Integer }- deriving (Eq, Show, Ord, Generic, NFData)+-- ** Logical Types +-- $ In addition to primitive types, Avro supports [**logical+-- types**](https://avro.apache.org/docs/current/spec.html#Logical+Types). A+-- logical type is represented the same way as a primitive type, but+-- has an extra annotation in the Avro schema that Avro libraries can+-- use to generate more specific types.+--+-- Example:+--+-- @+-- {+-- "type": "int",+-- "logicalType": "date"+-- }+-- @+--+-- The @date@ logical type represents a calendar date with no+-- timezone. It is encoded as an Avro @int@ with the number of days+-- from the Unix epoch (1970-01-01). Avro implementations /may/ parse+-- this type into a language-specific date type (eg 'Data.Time.Day' in+-- Haskell), but could also treat it as a normal Avro @int@ instead.+ newtype LogicalTypeBytes = DecimalB Decimal+ -- ^ An arbitrary-precision signed decimal number. See 'Decimal'. deriving (Eq, Show, Ord, Generic, NFData) data LogicalTypeFixed- = DecimalF Decimal | Duration+ = DecimalF Decimal+ -- ^ An arbitrary-precision signed decimal number. See 'Decimal'.+ | Duration+ -- ^ An interval of time, represented as some number of months,+ -- days and milliseconds.+ --+ -- Encoded as three little-endian unsigned integers for months,+ -- days and milliseconds respectively. deriving (Eq, Show, Ord, Generic, NFData) data LogicalTypeInt- = DecimalI Decimal | Date | TimeMillis+ = DecimalI Decimal+ -- ^ An arbitrary-precision signed decimal number. See 'Decimal'.+ | Date+ -- ^ A date (eg @2020-01-10@) with no timezone/locale.+ --+ -- Encoded as the number of days before/after the Unix epoch+ -- (1970-01-01).+ | TimeMillis+ -- ^ A time of day with millisecond precision.+ --+ -- Encoded as the number of milliseconds after midnight. deriving (Eq, Show, Ord, Generic, NFData) data LogicalTypeLong- = DecimalL Decimal | TimeMicros | TimestampMillis | TimestampMicros+ = DecimalL Decimal+ -- ^ An arbitrary-precision signed decimal number. See 'Decimal'.+ | TimeMicros+ -- ^ A time of day with microsecond precision.+ --+ -- Encoded as the number of microseconds after midnight.+ | TimestampMillis+ -- ^ A UTC timestamp with millisecond precision.+ --+ -- Encoded as the number of milliseconds before/after the Unix+ -- epoch (1970-01-01 00:00:00.000).+ | TimestampMicros+ -- ^ A UTC timestamp with microsecond precision.+ --+ -- Encoded as the number of microseconds before/after the Unix+ -- epoch (1970-01-01 00:00:00.000000).+ | LocalTimestampMillis+ -- ^ A timestamp in the local timezone, whatever that happens to+ -- be, with millisecond precision.+ --+ -- Encoded as the number of milliseconds before/after the Unix+ -- epoch (1970-01-01 00:00:00.000).+ | LocalTimestampMicros+ -- ^ A timestamp in the local timezone, whatever that happens to+ -- be, with microsecond precision.+ --+ -- Encoded as the number of microseconds before/after the Unix+ -- epoch (1970-01-01 00:00:00.000000). deriving (Eq, Show, Ord, Generic, NFData) data LogicalTypeString = UUID+ -- ^ A Universally Unique Identifier (UUID).+ --+ -- Encoded as a string that is valid according to [RFC+ -- 4122](https://www.ietf.org/rfc/rfc4122.txt). deriving (Eq, Show, Ord, Generic, NFData) +-- | The @decimal@ logical type represents arbitrary-precision decimal+-- numbers. Numbers are represented as @unscaled * (10 ** -scale)@+-- where @scale@ is part of the logical type and @unscaled@ is an+-- integer represented by the underlying primitive type.+--+-- Instances of the @decimal@ logical type need to specify a @scale@+-- and @precision@.+--+-- @decimal@ can be encoded as one of several different primitive+-- types:+--+-- * @bytes@+-- * @fixed@+-- * @long@+-- * @int@+--+-- For @long@ and @int@, @unscaled@ is the underlying number.+--+-- For @bytes@ and @fixed@, @unscaled@ is represented as a+-- two's-complement signed integer in big-endian byte order.+--+-- Note: @int@ and @long@ representations for @decimal@ are not part+-- of the [current Avro+-- specification](https://avro.apache.org/docs/current/spec.html#Decimal),+-- but they are supported by some language implementations including+-- the official Java library. Implementations that do not support this+-- should ignore the logical type and use the underlying primitive+-- type instead.+data Decimal+ = Decimal { precision :: Integer+ -- ^ The maximum number of digits that can be+ -- represented by this @decimal@ type.+ --+ -- @precision > 0@+ , scale :: Integer+ -- ^ The @scale@ in @unscaled * (10 ** -scale)@ for this+ -- type.+ --+ -- @0 ≤ scale ≤ precision@+ }+ deriving (Eq, Show, Ord, Generic, NFData)+ instance Eq Schema where Null == Null = True Boolean == Boolean = True@@ -320,9 +431,9 @@ -> TypeName -- ^ The resulting /fullname/ of the generated type, -- according to the rules laid out above.-mkTypeName context name ns+mkTypeName context name namespace_ | isFullName name = parseFullname name- | otherwise = case ns of+ | otherwise = case namespace_ of Just ns -> TN name $ filter (/= "") (T.splitOn "." ns) Nothing -> TN name $ maybe [] namespace context where isFullName = isJust . T.find (== '.')@@ -360,6 +471,10 @@ -> "timestamp-millis" Long (Just TimestampMicros) -> "timestamp-micros"+ Long (Just LocalTimestampMillis)+ -> "local-timestamp-millis"+ Long (Just LocalTimestampMicros)+ -> "local-timestamp-micros" Float -> "float" Double -> "double" Bytes Nothing -> "bytes"@@ -380,6 +495,15 @@ where decimalName (Decimal prec sc) = "decimal(" <> T.pack (show prec) <> "," <> T.pack (show sc) <> ")" +-- |Get the aliases of the type.+typeAliases :: Schema -> [TypeName]+typeAliases bt =+ case bt of+ Record { aliases } -> aliases+ Enum { aliases} -> aliases+ Fixed { aliases } -> aliases+ _ -> []+ instance FromJSON Schema where parseJSON = parseSchemaJSON Nothing @@ -395,21 +519,23 @@ -> Parser Schema parseSchemaJSON context = \case A.String s -> case s of- "null" -> return Null- "boolean" -> return Boolean- "int" -> return $ Int Nothing- "long" -> return $ Long Nothing- "float" -> return Float- "double" -> return Double- "bytes" -> return $ Bytes Nothing- "string" -> return $ String Nothing- "uuid" -> return $ String (Just UUID)- "date" -> return $ Int (Just Date)- "time-millis" -> return $ Int (Just TimeMillis)- "time-micros" -> return $ Long (Just TimeMicros)- "timestamp-millis" -> return $ Long (Just TimestampMillis)- "timestamp-micros" -> return $ Long (Just TimestampMicros)- somename -> return $ NamedType $ mkTypeName context somename Nothing+ "null" -> return Null+ "boolean" -> return Boolean+ "int" -> return $ Int Nothing+ "long" -> return $ Long Nothing+ "float" -> return Float+ "double" -> return Double+ "bytes" -> return $ Bytes Nothing+ "string" -> return $ String Nothing+ "uuid" -> return $ String (Just UUID)+ "date" -> return $ Int (Just Date)+ "time-millis" -> return $ Int (Just TimeMillis)+ "time-micros" -> return $ Long (Just TimeMicros)+ "timestamp-millis" -> return $ Long (Just TimestampMillis)+ "timestamp-micros" -> return $ Long (Just TimestampMicros)+ "local-timestamp-millis" -> return $ Long (Just LocalTimestampMillis)+ "local-timestamp-micros" -> return $ Long (Just LocalTimestampMicros)+ somename -> return $ NamedType $ mkTypeName context somename Nothing A.Array arr | V.length arr > 0 -> Union <$> V.mapM (parseSchemaJSON context) arr@@ -447,6 +573,12 @@ Just "timestamp-micros" -> case ty of "long" -> pure $ Long (Just TimestampMicros) s -> fail $ "Unsupported underlying type: " <> T.unpack s+ Just "local-timestamp-millis" -> case ty of+ "long" -> pure $ Long (Just LocalTimestampMillis)+ s -> fail $ "Unsupported underlying type: " <> T.unpack s+ Just "local-timestamp-micros" -> case ty of+ "long" -> pure $ Long (Just LocalTimestampMicros)+ s -> fail $ "Unsupported underlying type: " <> T.unpack s Just "duration" -> case ty of "fixed" -> (\fx -> fx { logicalTypeF = Just Duration }) <$> parseFixed o s -> fail $ "Unsupported underlying type: " <> T.unpack s@@ -455,23 +587,21 @@ "map" -> Map <$> (parseSchemaJSON context =<< o .: "values") "array" -> Array <$> (parseSchemaJSON context =<< o .: "items") "record" -> do- name <- o .: "name"- namespace <- o .:? "namespace"- let typeName = mkTypeName context name namespace- mkAlias name = mkTypeName (Just typeName) name Nothing- aliases <- mkAliases typeName <$> (o .:? "aliases" .!= [])- doc <- o .:? "doc"- fields <- mapM (parseField typeName) =<< (o .: "fields")- pure $ Record typeName aliases doc fields+ name <- o .: "name"+ namespace <- o .:? "namespace"+ let recName = mkTypeName context name namespace+ aliases <- mkAliases recName <$> (o .:? "aliases" .!= [])+ doc <- o .:? "doc"+ fields <- mapM (parseField recName) =<< (o .: "fields")+ pure $ Record recName aliases doc fields "enum" -> do- name <- o .: "name"- namespace <- o .:? "namespace"- let typeName = mkTypeName context name namespace- mkAlias name = mkTypeName (Just typeName) name Nothing- aliases <- mkAliases typeName <$> (o .:? "aliases" .!= [])- doc <- o .:? "doc"- symbols <- o .: "symbols"- pure $ mkEnum typeName aliases doc symbols+ name <- o .: "name"+ namespace <- o .:? "namespace"+ let enumName = mkTypeName context name namespace+ aliases <- mkAliases enumName <$> (o .:? "aliases" .!= [])+ doc <- o .:? "doc"+ symbols <- o .: "symbols"+ pure $ mkEnum enumName aliases doc symbols "fixed" -> parseFixed o "null" -> pure Null "boolean" -> pure Boolean@@ -487,13 +617,12 @@ where parseFixed o = do- name <- o .: "name"- namespace <- o .:? "namespace"- let typeName = mkTypeName context name namespace- mkAlias name = mkTypeName (Just typeName) name Nothing- aliases <- mkAliases typeName <$> (o .:? "aliases" .!= [])- size <- o .: "size"- pure $ Fixed typeName aliases size Nothing+ name <- o .: "name"+ namespace <- o .:? "namespace"+ let fixedName = mkTypeName context name namespace+ aliases <- mkAliases fixedName <$> (o .:? "aliases" .!= [])+ size <- o .: "size"+ pure $ Fixed fixedName aliases size Nothing -- | Parse aliases, inferring the namespace based on the type being aliases. mkAliases :: TypeName@@ -523,9 +652,7 @@ Just (Success x) -> return (Just x) Just (Error e) -> fail e Nothing -> return Nothing- order <- o .:? ("order" :: Text) .!= Just Ascending-- let mkAlias name = mkTypeName (Just record) name Nothing+ order <- o .:? "order" .!= Just Ascending aliases <- o .:? "aliases" .!= [] return $ Field name aliases doc order ty def invalid -> typeMismatch "Field" invalid@@ -566,6 +693,10 @@ object [ "type" .= ("long" :: Text), "logicalType" .= ("timestamp-millis" :: Text) ] Long (Just TimestampMicros) -> object [ "type" .= ("long" :: Text), "logicalType" .= ("timestamp-micros" :: Text) ]+ Long (Just LocalTimestampMillis) ->+ object [ "type" .= ("long" :: Text), "logicalType" .= ("local-timestamp-millis" :: Text) ]+ Long (Just LocalTimestampMicros) ->+ object [ "type" .= ("long" :: Text), "logicalType" .= ("local-timestamp-micros" :: Text) ] Float -> A.String "float" Double -> A.String "double" Bytes Nothing -> A.String "bytes"@@ -613,12 +744,12 @@ -> [ "logicalType" .= ("decimal" :: Text) , "precision" .= prec, "scale" .= sc ] in object (basic ++ extended)- where render context typeName- | Just ctx <- context- , namespace ctx == namespace typeName = baseName typeName- | otherwise = renderFullname typeName+ where render context1 typeName1+ | Just ctx <- context1+ , namespace ctx == namespace typeName1 = baseName typeName1+ | otherwise = renderFullname typeName1 - fieldToJSON context Field {..} =+ fieldToJSON context1 Field {..} = let opts = catMaybes [ ("order" .=) <$> fldOrder , ("doc" .=) <$> fldDoc@@ -626,7 +757,7 @@ ] in object $ opts ++ [ "name" .= fldName- , "type" .= schemaToJSON (Just context) fldType+ , "type" .= schemaToJSON (Just context1) fldType , "aliases" .= fldAliases ] @@ -647,10 +778,10 @@ DBytes _ bs -> A.String (serializeBytes bs) DString _ t -> A.String t DArray vec -> A.Array (V.map toJSON vec)- DMap mp -> A.Object (HashMap.map toJSON mp)- DRecord _ flds -> A.Object (HashMap.map toJSON flds)+ DMap mp -> A.Object $ fmap toJSON (KM.fromHashMapText mp)+ DRecord _ flds -> A.Object $ fmap toJSON (KM.fromHashMapText flds) DUnion _ _ DNull -> A.Null- DUnion _ ty val -> object [ typeName ty .= val ]+ DUnion _ ty val -> object [ A.fromText (typeName ty) .= val ] DFixed _ bs -> A.String (serializeBytes bs) DEnum _ _ txt -> A.String txt @@ -670,7 +801,7 @@ instance Monad Result where return = pure Success a >>= k = k a- Error e >>= _ = Error e+ Error e >>= _ = Error e #if !MIN_VERSION_base(4,13,0) fail = MF.fail #endif@@ -774,10 +905,10 @@ _ -> avroTypeMismatch ty "array" A.Object obj -> case ty of- Map mTy -> DMap <$> mapM (parseAvroJSON union env mTy) obj+ Map mTy -> DMap <$> mapM (parseAvroJSON union env mTy) (KM.toHashMapText obj) Record {..} -> do let lkAndParse f =- case HashMap.lookup (fldName f) obj of+ case KM.lookup (A.fromText (fldName f)) obj of Nothing -> case fldDefault f of Just v -> return v Nothing -> fail $ "Decode failure: No record field '" <> T.unpack (fldName f) <> "' and no default in schema."@@ -903,7 +1034,7 @@ t@(NamedType n) -> fromMaybe t <$> gets (HashMap.lookup n) a@Array{item} -> (\x -> a { item = x }) <$> go item m@Map{values} -> (\x -> m { values = x }) <$> go values- u@Union{options} -> Union <$> traverse go options+ Union{options} -> Union <$> traverse go options r@Record{name, fields} -> do fields' <- traverse expandField fields@@ -926,11 +1057,11 @@ overlayType a@Array{..} = a { item = overlayType item } overlayType m@Map{..} = m { values = overlayType values } overlayType r@Record{..} = r { fields = map overlayField fields }- overlayType u@Union{..} = Union (fmap overlayType options)- overlayType nt@(NamedType _) = rebind nt+ overlayType Union{..} = Union (fmap overlayType options)+ overlayType (NamedType nt) = rebind nt overlayType other = other - rebind (NamedType tn) = HashMap.lookupDefault (NamedType tn) tn bindings+ rebind tn = HashMap.lookupDefault (NamedType tn) tn bindings bindings = extractBindings supplement -- | Extract the named inner type definition as its own schema.
test/Avro/Data/Logical.hs view
@@ -15,7 +15,7 @@ module Avro.Data.Logical where -import Data.Avro.Internal.Time (microsToDiffTime, microsToUTCTime, millisToDiffTime, millisToUTCTime)+import Data.Avro.Internal.Time (microsToDiffTime, microsToLocalTime, microsToUTCTime, millisToDiffTime, millisToLocalTime, millisToUTCTime) import Data.Avro.Deriving (deriveAvroFromByteString, r) @@ -59,7 +59,23 @@ "logicalType": "time-micros", "type": "long" }- }+ },+ {+ "name": "localTimestampMillis",+ "type":+ {+ "logicalType": "local-timestamp-millis",+ "type": "long"+ }+ },+ {+ "name": "localTimestampMicros",+ "type":+ {+ "logicalType": "local-timestamp-micros",+ "type": "long"+ }+ } ] } |]@@ -70,3 +86,5 @@ <*> (microsToUTCTime . toInteger <$> Gen.int64 (Range.linear 0 maxBound)) <*> (millisToDiffTime . toInteger <$> Gen.int32 (Range.linear 0 maxBound)) <*> (microsToDiffTime . toInteger <$> Gen.int64 (Range.linear 0 maxBound))+ <*> (millisToLocalTime . toInteger <$> Gen.int64 (Range.linear 0 maxBound))+ <*> (microsToLocalTime . toInteger <$> Gen.int64 (Range.linear 0 maxBound))
+ test/Avro/Data/TwoBits.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NumDecimals #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++module Avro.Data.TwoBits+where++import Data.Avro.Deriving (deriveAvroFromByteString, r)++import Hedgehog+import Hedgehog.Gen as Gen+import Hedgehog.Range as Range++import qualified Data.ByteString.Lazy as LBS++twoBits'rawSchema :: LBS.ByteString+twoBits'rawSchema = [r|+{+ "type": "record",+ "name": "TwoBits",+ "fields": [+ { "name": "bit0",+ "type": {+ "type": "enum",+ "name": "Bit",+ "symbols": [ "Zero", "One"]+ }+ },+ { "name": "bit1",+ "type": "Bit"+ }+ ]+}+|]+++deriveAvroFromByteString [r|+{+ "type": "record",+ "name": "TwoBits",+ "fields": [+ { "name": "bit0",+ "type": {+ "type": "enum",+ "name": "Bit",+ "symbols": [ "Zero", "One"]+ }+ },+ { "name": "bit1",+ "type": "Bit"+ }+ ]+}+|]
test/Avro/DefaultsSpec.hs view
@@ -4,6 +4,7 @@ where import qualified Data.Aeson as J+import qualified Data.Aeson.KeyMap as KM import Data.Avro.Schema.Schema import qualified Data.HashMap.Strict as M import Data.List.NonEmpty (NonEmpty (..))@@ -36,6 +37,6 @@ let msgSchema = schema'MaybeTest (J.Object jSchema) = J.toJSON msgSchema- (Just (J.Array flds)) = M.lookup "fields" jSchema+ (Just (J.Array flds)) = KM.lookup "fields" jSchema (J.Object jFld) = V.head flds- in M.lookup "default" jFld `shouldBe` Just J.Null+ in KM.lookup "default" jFld `shouldBe` Just J.Null
test/Avro/Gen/Schema.hs view
@@ -27,4 +27,6 @@ long :: MonadGen m => m Schema long = do dec <- decimalGen- Long <$> Gen.maybe (Gen.element [DecimalL dec, TimeMicros, TimestampMillis, TimestampMicros])+ Long <$> Gen.maybe (Gen.element+ [DecimalL dec, TimeMicros, TimestampMillis,+ TimestampMicros, LocalTimestampMillis, LocalTimestampMicros])
test/Avro/NormSchemaSpec.hs view
@@ -1,14 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module Avro.NormSchemaSpec where import Data.Avro.Schema.Schema (Schema (..), fields, fldType, mkUnion) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Set as S--import Avro.Data.Karma-import Avro.Data.Reused+import qualified Data.Aeson as Aeson+import Avro.Data.Karma+import Avro.Data.Reused+import Avro.Data.TwoBits import Test.Hspec @@ -21,3 +23,7 @@ it "should normalise schemas from unions" $ fldType <$> fields schema'Curse `shouldBe` [mkUnion (Null :| [schema'Geo])]++ it "should serialise reused schema correctly" $+ let Just expected = Aeson.encode <$> Aeson.decode @Schema twoBits'rawSchema+ in Aeson.encode schema'TwoBits `shouldBe` expected