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: 670416b0f08afc67a117327ae67a257a6c00faecea07e66d765393ef9e7786fa +-- hash: 227dce7b3b510a3f986c3dd8ba7a73b2e32ef06ef0d81005408e20f9c8eadc2d name: avro -version: 0.3.5.2 +version: 0.3.6.0 synopsis: Avro serialization support for Haskell description: Avro serialization and deserialization support for Haskell category: Data @@ -23,10 +23,10 @@ test/data/deconflict/writer.avsc test/data/enums-object.json test/data/enums.avsc - test/data/internal-bindings.avsc test/data/karma.avsc test/data/logical.avsc test/data/maybe.avsc + test/data/namespace-inference.json test/data/record.avsc test/data/reused.avsc test/data/small.avsc @@ -133,6 +133,7 @@ Avro.DefaultsSpec Avro.EncodeRawSpec Avro.JSONSpec + Avro.NamespaceSpec Avro.NormSchemaSpec Avro.SchemaSpec Avro.THEncodeContainerSpec diff --git a/src/Data/Avro/Decode/Get.hs b/src/Data/Avro/Decode/Get.hs --- a/src/Data/Avro/Decode/Get.hs +++ b/src/Data/Avro/Decode/Get.hs @@ -147,7 +147,11 @@ G.getByteString (fromIntegral w) getString :: Get Text -getString = Text.decodeUtf8 <$> getBytes +getString = do + bytes <- getBytes + case Text.decodeUtf8' bytes of + Left unicodeExc -> fail (show unicodeExc) + Right text -> return text -- a la Java: -- Bit 31 (the bit that is selected by the mask 0x80000000) represents the 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 @@ -6,21 +6,29 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +-- | This module lets us derive Haskell types from an Avro schema that +-- can be serialized/deserialzed to Avro. module Data.Avro.Deriving -( -- * Deriving options - DeriveOptions(..), FieldStrictness(..), FieldUnpackedness(..) -, defaultDeriveOptions -, mkPrefixedFieldName, mkAsIsFieldName -, mkLazyField, mkStrictPrimitiveField + ( -- * Deriving options + DeriveOptions(..) + , FieldStrictness(..) + , FieldUnpackedness(..) + , NamespaceBehavior(..) + , defaultDeriveOptions + , mkPrefixedFieldName + , mkAsIsFieldName + , mkLazyField + , mkStrictPrimitiveField -- * Deriving Haskell types from Avro schema -, makeSchema -, deriveAvroWithOptions -, deriveAvroWithOptions' -, deriveFromAvroWithOptions -, deriveAvro -, deriveAvro' -, deriveFromAvro + , makeSchema + , makeSchemaFrom + , deriveAvroWithOptions + , deriveAvroWithOptions' + , deriveFromAvroWithOptions + , deriveAvro + , deriveAvro' + , deriveFromAvro ) where @@ -39,7 +47,11 @@ import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) +import qualified Data.Text as Text + + 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 @@ -56,6 +68,26 @@ import qualified Data.Text as T import qualified Data.Vector as V +-- | How to treat Avro namespaces in the generated Haskell types. +data NamespaceBehavior = + IgnoreNamespaces + -- ^ Namespaces are ignored completely. Haskell identifiers are + -- generated from types' base names. This produces nicer types but + -- fails on valid Avro schemas where the same base name occurs in + -- different namespaces. + -- + -- The Avro type @com.example.Foo@ would generate the Haskell type + -- @Foo@. If @Foo@ had a field called @bar@, the generated Haskell + -- record would have a field called @fooBar@. + | HandleNamespaces + -- ^ Haskell types and field names are generated with + -- namespaces. See 'deriveAvroWithNamespaces' for an example of + -- how this works. + -- + -- The Avro type @com.example.Foo@ would generate the Haskell type + -- @Com'example'Foo@. If @Foo@ had a field called @bar@, the + -- generated Haskell record would have the field + -- @com'example'FooBar@. -- | Describes the strictness of a field for a derived -- data type. The field will be derived as if it were @@ -72,24 +104,32 @@ -- | Derives Avro from a given schema file. -- Generates data types, FromAvro and ToAvro instances. data DeriveOptions = DeriveOptions - { -- | How to build field names for generated data types - fieldNameBuilder :: TypeName -> Field -> T.Text + { -- | 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 -- | Determines field representation of generated data types , fieldRepresentation :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness) + + -- | Controls how we handle namespaces when defining Haskell type + -- and field names. + , namespaceBehavior :: NamespaceBehavior } deriving Generic -- | Default deriving options -- -- @ -- defaultDeriveOptions = 'DeriveOptions' --- { fieldNameBuilder = 'mkPrefixedFieldName' --- , fieldStrictness = 'mkLazyField' +-- { fieldNameBuilder = 'mkPrefixedFieldName' +-- , fieldStrictness = 'mkLazyField' +-- , namespaceBehavior = 'IgnoreNamespaces' -- } -- @ defaultDeriveOptions = DeriveOptions { fieldNameBuilder = mkPrefixedFieldName , fieldRepresentation = mkLazyField + , namespaceBehavior = IgnoreNamespaces } -- | Generates a field name that is prefixed with the type name. @@ -100,10 +140,9 @@ -- @ -- Person { personFirstName :: Text } -- @ -mkPrefixedFieldName :: TypeName -> Field -> T.Text -mkPrefixedFieldName (TN dn) fld = sanitiseName $ - updateFirst T.toLower dn <> updateFirst T.toUpper (fldName fld) - +mkPrefixedFieldName :: Text -> Field -> T.Text +mkPrefixedFieldName prefix fld = + sanitiseName $ updateFirst T.toLower prefix <> updateFirst T.toUpper (fldName fld) -- | Marks any field as non-strict in the generated data types. mkLazyField :: TypeName -> Field -> (FieldStrictness, FieldUnpackedness) @@ -146,40 +185,92 @@ -- Person { firstName :: Text } -- @ -- You may want to enable 'DuplicateRecordFields' if you want to use this method. - mkAsIsFieldName :: TypeName -> Field -> Text mkAsIsFieldName _ = sanitiseName . updateFirst T.toLower . fldName --- | Generates Haskell classes and 'FromAvro' and 'ToAvro' instances --- given the Avro schema file +-- | Derives Haskell types from the given Avro schema file. These +-- Haskell types support both reading and writing to Avro. +-- +-- For an Avro schema with a top-level record called +-- @com.example.Foo@, this generates: +-- +-- * a 'Schema' with the name @schema'Foo@ or +-- @schema'com'example'Foo@, depending on the 'namespaceBehavior' +-- setting. +-- +-- * Haskell types for each named type defined in the schema +-- * 'HasSchema' instances for each type +-- * 'FromAvro' instances for each type +-- * 'ToAvro' instances for each type +-- +-- This function ignores namespaces when generated Haskell type and +-- field names. This will fail on valid Avro schemas which contain +-- types with the same base name in different namespaces. It will also +-- fail for schemas that contain types with base names that are the +-- same except for the capitalization of the first letter. +-- +-- The type @com.example.Foo@ will generate a Haskell type @Foo@. If +-- @com.example.Foo@ has a field named @Bar@, the field in the Haskell +-- record will be called @fooBar@. deriveAvroWithOptions :: DeriveOptions -> FilePath -> Q [Dec] deriveAvroWithOptions o p = readSchema p >>= deriveAvroWithOptions' o --- | Generates Haskell classes and 'FromAvro' and 'ToAvro' instances --- given the Avro schema +-- | Derive Haskell types from the given Avro schema. +-- +-- For an Avro schema with a top-level definition @com.example.Foo@, this +-- generates: +-- +-- * a 'Schema' with the name @schema'Foo@ or +-- @schema'com'example'Foo@ depending on namespace handling +-- +-- * Haskell types for each named type defined in the schema +-- * 'HasSchema' instances for each type +-- * 'FromAvro' instances for each type +-- * 'ToAvro' instances for each type deriveAvroWithOptions' :: DeriveOptions -> Schema -> Q [Dec] deriveAvroWithOptions' o s = do let schemas = extractDerivables s types <- traverse (genType o) schemas - hasSchema <- traverse genHasAvroSchema schemas - fromAvros <- traverse genFromAvro schemas + hasSchema <- traverse (genHasAvroSchema $ namespaceBehavior o) schemas + fromAvros <- traverse (genFromAvro $ namespaceBehavior o) schemas toAvros <- traverse (genToAvro o) schemas pure $ join types <> join hasSchema <> join fromAvros <> join toAvros --- | Derives "read only" Avro from a given schema file. --- Generates data types and FromAvro. +-- | Derives "read only" Avro from a given schema file. For a schema +-- with a top-level definition @com.example.Foo@, this generates: +-- +-- * a 'Schema' value with the name @schema'Foo@ +-- +-- * Haskell types for each named type defined in the schema +-- * 'HasSchema' instances for each type +-- * 'FromAvro' instances for each type deriveFromAvroWithOptions :: DeriveOptions -> FilePath -> Q [Dec] -deriveFromAvroWithOptions o p = do - schemas <- extractDerivables <$> readSchema p +deriveFromAvroWithOptions o p = readSchema p >>= deriveFromAvroWithOptions' o + +-- | Derive "read only" Haskell types from the given Avro schema with +-- configurable behavior for handling namespaces. +-- +-- For an Avro schema with a top-level definition @com.example.Foo@, this +-- generates: +-- +-- * a 'Schema' with the name @schema'Foo@ or +-- @schema'com'example'Foo@ depending on namespace handling +-- +-- * Haskell types for each named type defined in the schema +-- * 'HasSchema' instances for each type +-- * 'FromAvro' instances for each type +deriveFromAvroWithOptions' :: DeriveOptions -> Schema -> Q [Dec] +deriveFromAvroWithOptions' o s = do + let schemas = extractDerivables s types <- traverse (genType o) schemas - hasSchema <- traverse genHasAvroSchema schemas - fromAvros <- traverse genFromAvro schemas + hasSchema <- traverse (genHasAvroSchema $ namespaceBehavior o) schemas + fromAvros <- traverse (genFromAvro $ namespaceBehavior o) schemas pure $ join types <> join hasSchema <> join fromAvros -- | Same as 'deriveAvroWithOptions' but uses 'defaultDeriveOptions' -- -- @ --- deriveAvro' = deriveAvroWithOptions' 'defaultDeriveOptions' +-- deriveAvro = 'deriveAvroWithOptions' 'defaultDeriveOptions' -- @ deriveAvro :: FilePath -> Q [Dec] deriveAvro = deriveAvroWithOptions defaultDeriveOptions @@ -192,8 +283,12 @@ deriveAvro' :: Schema -> Q [Dec] deriveAvro' = deriveAvroWithOptions' defaultDeriveOptions --- | Derives "read only" Avro from a given schema file. --- Generates data types and FromAvro. +-- | Same as 'deriveFromAvroWithOptions' but uses +-- 'defaultDeriveOptions'. +-- +-- @ +-- deriveFromAvro = deriveFromAvroWithOptions defaultDeriveOptions +-- @ deriveFromAvro :: FilePath -> Q [Dec] deriveFromAvro = deriveFromAvroWithOptions defaultDeriveOptions @@ -207,6 +302,14 @@ makeSchema :: FilePath -> Q Exp makeSchema p = readSchema p >>= schemaDef' +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 + Just ss -> schemaDef' ss + readSchema :: FilePath -> Q Schema readSchema p = do qAddDependentFile p @@ -215,23 +318,25 @@ Left err -> fail $ "Unable to generate AVRO for " <> p <> ": " <> err Right sch -> pure sch -genFromAvro :: Schema -> Q [Dec] -genFromAvro (S.Enum n _ _ _ _ _) = - [d| instance FromAvro $(conT $ mkDataTypeName n) where +genFromAvro :: NamespaceBehavior -> Schema -> Q [Dec] +genFromAvro namespaceBehavior (S.Enum n _ _ _ _) = + [d| instance FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where fromAvro (AT.Enum _ i _) = $([| pure . toEnum|]) i - fromAvro value = $( [|\v -> badValue v $(mkTextLit $ unTN n)|] ) value + fromAvro value = $( [|\v -> badValue v $(mkTextLit $ S.renderFullname n)|] ) value |] -genFromAvro (S.Record n _ _ _ _ fs) = - [d| instance FromAvro $(conT $ mkDataTypeName n) where - fromAvro (AT.Record _ r) = $(genFromAvroFieldsExp (mkTextName $ unTN n) fs) r - fromAvro value = $( [|\v -> badValue v $(mkTextLit $ unTN n)|] ) value +genFromAvro namespaceBehavior (S.Record n _ _ _ fs) = + [d| instance FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where + fromAvro (AT.Record _ r) = + $(genFromAvroFieldsExp (mkDataTypeName namespaceBehavior n) fs) r + fromAvro value = $( [|\v -> badValue v $(mkTextLit $ S.renderFullname n)|] ) value |] -genFromAvro (S.Fixed n _ _ s) = - [d| instance FromAvro $(conT $ mkDataTypeName n) where - fromAvro (AT.Fixed _ v) | BS.length v == s = pure $ $(conE (mkDataTypeName n)) v - fromAvro value = $( [|\v -> badValue v $(mkTextLit $ unTN n)|] ) value +genFromAvro namespaceBehavior (S.Fixed n _ s) = + [d| instance FromAvro $(conT $ mkDataTypeName namespaceBehavior n) where + fromAvro (AT.Fixed _ v) + | BS.length v == s = pure $ $(conE (mkDataTypeName namespaceBehavior n)) v + fromAvro value = $( [|\v -> badValue v $(mkTextLit $ S.renderFullname n)|] ) value |] -genFromAvro _ = pure [] +genFromAvro _ _ = pure [] genFromAvroFieldsExp :: Name -> [Field] -> Q Exp genFromAvroFieldsExp n [] = [| (return . return) $(conE n) |] @@ -243,45 +348,48 @@ ) |] -genHasAvroSchema :: Schema -> Q [Dec] -genHasAvroSchema s = do - let sname = mkSchemaValueName (name s) +genHasAvroSchema :: NamespaceBehavior -> Schema -> Q [Dec] +genHasAvroSchema namespaceBehavior s = do + let sname = mkSchemaValueName namespaceBehavior (name s) sdef <- schemaDef sname s idef <- hasAvroSchema sname pure (sdef <> idef) where hasAvroSchema sname = - [d| instance HasAvroSchema $(conT $ mkDataTypeName (name s)) where + [d| instance HasAvroSchema $(conT $ mkDataTypeName namespaceBehavior (name s)) where schema = pure $(varE sname) |] -newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name] -newNames base n = sequence [ newName (base++show i) | i <- [1..n] ] +newNames :: String + -- ^ base name + -> Int + -- ^ count + -> Q [Name] +newNames base n = sequence [newName (base ++ show i) | i <- [1..n]] genToAvro :: DeriveOptions -> Schema -> Q [Dec] -genToAvro opts s@(Enum n _ _ _ vs _) = - toAvroInstance (mkSchemaValueName n) +genToAvro opts s@(Enum n _ _ vs _) = + toAvroInstance (mkSchemaValueName (namespaceBehavior opts) n) where - conP' = flip conP [] . mkAdtCtorName n + conP' = flip conP [] . mkAdtCtorName (namespaceBehavior opts) n toAvroInstance sname = - [d| instance ToAvro $(conT $ mkDataTypeName n) where + [d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where toAvro = $([| \x -> let convert = AT.Enum $(varE sname) (fromEnum $([|x|])) in $(caseE [|x|] ((\v -> match (conP' v) (normalB [| convert (T.pack $(mkTextLit v))|]) []) <$> vs)) |]) |] - -genToAvro opts s@(Record n _ _ _ _ fs) = - toAvroInstance (mkSchemaValueName n) +genToAvro opts s@(Record n _ _ _ fs) = + toAvroInstance (mkSchemaValueName (namespaceBehavior opts) n) where toAvroInstance sname = - [d| instance ToAvro $(conT $ mkDataTypeName n) where + [d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where toAvro = $(genToAvroFieldsExp sname) |] genToAvroFieldsExp sname = do names <- newNames "p_" (length fs) - let con = conP (mkDataTypeName n) (varP <$> names) + let con = conP (mkDataTypeName (namespaceBehavior opts) n) (varP <$> names) lamE [con] [| record $(varE sname) $(let assign (fld, n) = [| T.pack $(mkTextLit (fldName fld)) .= $(varE n) |] @@ -289,14 +397,14 @@ ) |] -genToAvro opts s@(Fixed n _ _ size) = - toAvroInstance (mkSchemaValueName n) +genToAvro opts s@(Fixed n _ size) = + toAvroInstance (mkSchemaValueName (namespaceBehavior opts) n) where toAvroInstance sname = - [d| instance ToAvro $(conT $ mkDataTypeName n) where + [d| instance ToAvro $(conT $ mkDataTypeName (namespaceBehavior opts) n) where toAvro = $(do x <- newName "x" - lamE [conP (mkDataTypeName n) [varP x]] [| AT.Fixed $(varE sname) $(varE x) |]) + lamE [conP (mkDataTypeName (namespaceBehavior opts) n) [varP x]] [| AT.Fixed $(varE sname) $(varE x) |]) |] schemaDef :: Name -> Schema -> Q [Dec] @@ -321,7 +429,6 @@ Map values -> [e| Map $(mkSchema values) |] NamedType name -> [e| NamedType $(mkName name) |] Record {..} -> [e| Record { name = $(mkName name) - , namespace = $(mkMaybeText namespace) , aliases = $(ListE <$> mapM mkName aliases) , doc = $(mkMaybeText doc) , order = $(mkOrder order) @@ -330,13 +437,11 @@ |] Enum {..} -> [e| mkEnum $(mkName name) $(ListE <$> mapM mkName aliases) - $(mkMaybeText namespace) $(mkMaybeText doc) $(ListE <$> mapM mkText symbols) |] Union {..} -> [e| mkUnion $(mkNE options) |] Fixed {..} -> [e| Fixed { name = $(mkName name) - , namespace = $(mkMaybeText namespace) , aliases = $(ListE <$> mapM mkName aliases) , size = $(litE $ IntegerL $ fromIntegral size) } @@ -344,7 +449,8 @@ mkText text = [e| T.pack $(mkTextLit text) |] - mkName (TN name) = [e| TN $(mkText name) |] + mkName (TN name namespace) = [e| TN $(mkText name) $(mkNamespace namespace) |] + mkNamespace ls = listE $ stringE . T.unpack <$> ls mkMaybeText (Just text) = [e| Just $(mkText text) |] mkMaybeText Nothing = [e| Nothing |] @@ -401,42 +507,45 @@ sn _ d = d genType :: DeriveOptions -> Schema -> Q [Dec] -genType opts (S.Record n _ _ _ _ fs) = do +genType opts (S.Record n _ _ _ fs) = do flds <- traverse (mkField opts n) fs - let dname = mkDataTypeName n + let dname = mkDataTypeName (namespaceBehavior opts) n sequenceA [genDataType dname flds] -genType _ (S.Enum n _ _ _ vs _) = do - let dname = mkDataTypeName n - sequenceA [genEnum dname (mkAdtCtorName n <$> vs)] -genType _ (S.Fixed n _ _ s) = do - let dname = mkDataTypeName n +genType opts (S.Enum n _ _ vs _) = do + let dname = mkDataTypeName (namespaceBehavior opts) n + sequenceA [genEnum dname (mkAdtCtorName (namespaceBehavior opts) n <$> vs)] +genType opts (S.Fixed n _ s) = do + let dname = mkDataTypeName (namespaceBehavior opts) n sequenceA [genNewtype dname] - genType _ _ = pure [] -mkFieldTypeName :: S.Type -> Q TH.Type -mkFieldTypeName t = case t of - S.Boolean -> [t| Bool |] - S.Long -> [t| Int64 |] - S.Int -> [t| Int32 |] - S.Float -> [t| Float |] - S.Double -> [t| Double |] - S.Bytes -> [t| ByteString |] - S.String -> [t| Text |] - 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 (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) - S.NamedType n -> [t| $(conT $ mkDataTypeName n)|] --ConT . mkName . T.unpack . mkDataTypeName $ x - S.Fixed n _ _ _ -> [t| $(conT $ mkDataTypeName n)|] --ConT . mkName . T.unpack . mkDataTypeName $ x - S.Enum n _ _ _ _ _ -> [t| $(conT $ mkDataTypeName n)|] - _ -> error $ "Avro type is not supported: " <> show t +mkFieldTypeName :: NamespaceBehavior -> S.Type -> Q TH.Type +mkFieldTypeName namespaceBehavior = \case + S.Boolean -> [t| Bool |] + S.Long -> [t| Int64 |] + S.Int -> [t| Int32 |] + S.Float -> [t| Float |] + S.Double -> [t| Double |] + S.Bytes -> [t| ByteString |] + S.String -> [t| Text |] + S.Union branches _ -> union 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)|] + t -> error $ "Avro type is not supported: " <> show t + where go = mkFieldTypeName namespaceBehavior + union = \case + 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) |] + _ -> + error "Unions with more than 5 elements are not yet supported" updateFirst :: (Text -> Text) -> Text -> Text updateFirst f t = @@ -446,9 +555,9 @@ decodeSchema :: FilePath -> IO (Either String Schema) decodeSchema p = eitherDecode <$> LBS.readFile p -mkAdtCtorName :: TypeName -> Text -> Name -mkAdtCtorName prefix nm = - concatNames (mkDataTypeName prefix) (mkDataTypeName' nm) +mkAdtCtorName :: NamespaceBehavior -> TypeName -> Text -> Name +mkAdtCtorName namespaceBehavior prefix nm = + concatNames (mkDataTypeName namespaceBehavior prefix) (mkDataTypeName' nm) concatNames :: Name -> Name -> Name concatNames a b = mkName $ nameBase a <> nameBase b @@ -458,22 +567,47 @@ let valid c = isAlphaNum c || c == '\'' || c == '_' in T.concat . T.split (not . valid) -mkSchemaValueName :: TypeName -> Name -mkSchemaValueName (TN n) = mkTextName $ "schema'" <> n +-- | Renders a fully qualified Avro name to a valid Haskell +-- identifier. This does not change capitalization—make sure to +-- capitalize as needed depending on whether the name is a Haskell +-- type, constructor, variable or field. +-- +-- With 'HandleNamespaces', namespace components (if any) are +-- separated with @'@. The Avro name @"com.example.foo"@ would be +-- rendered as @com'example'foo@. +-- +-- With 'IgnoreNamespaces', only the base name of the type is +-- used. The Avro name @"com.example.foo"@ would be rendered as +-- @"foo"@. +renderName :: NamespaceBehavior + -- ^ How to handle namespaces when generating the type + -- name. + -> TypeName + -- ^ The name to transform into a valid Haskell + -- identifier. + -> Text +renderName namespaceBehavior (TN name namespace) = case namespaceBehavior of + HandleNamespaces -> Text.intercalate "'" $ namespace <> [name] + IgnoreNamespaces -> name -mkDataTypeName :: TypeName -> Name -mkDataTypeName = mkDataTypeName' . unTN +mkSchemaValueName :: NamespaceBehavior -> TypeName -> Name +mkSchemaValueName namespaceBehavior typeName = + mkTextName $ "schema'" <> renderName namespaceBehavior typeName +mkDataTypeName :: NamespaceBehavior -> TypeName -> Name +mkDataTypeName namespaceBehavior = mkDataTypeName' . renderName namespaceBehavior + mkDataTypeName' :: Text -> Name mkDataTypeName' = mkTextName . sanitiseName . updateFirst T.toUpper . T.takeWhileEnd (/='.') mkField :: DeriveOptions -> TypeName -> Field -> Q VarStrictType -mkField opts prefix field = do - ftype <- mkFieldTypeName (fldType field) - let fName = mkTextName $ (fieldNameBuilder opts) prefix field +mkField opts typeName field = do + ftype <- mkFieldTypeName (namespaceBehavior opts) (fldType field) + let prefix = renderName (namespaceBehavior opts) typeName + fName = mkTextName $ (fieldNameBuilder opts) prefix field (fieldStrictness, fieldUnpackedness) = - fieldRepresentation opts prefix field + fieldRepresentation opts typeName field strictness = case fieldStrictness of StrictField -> strict fieldUnpackedness diff --git a/src/Data/Avro/Deriving/NormSchema.hs b/src/Data/Avro/Deriving/NormSchema.hs --- a/src/Data/Avro/Deriving/NormSchema.hs +++ b/src/Data/Avro/Deriving/NormSchema.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Data.Avro.Deriving.NormSchema @@ -38,18 +39,16 @@ -- Ensures normalisation: "extracted" record is self-contained and -- all the named types are resolvable within the scope of the schema. --- TODO: Improve story with namespaces normSchema :: Schema -> State (M.Map TypeName Schema) Schema normSchema r = case r of t@(NamedType tn) -> do - let sn = shortName tn resolved <- get - case M.lookup sn resolved of + case M.lookup tn resolved of Just rs -> -- 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 sn t) >> pure rs + modify' (M.insert tn t) >> pure rs -- NamedType but no corresponding record?! Baaad! Nothing -> @@ -59,12 +58,9 @@ Map s -> Map <$> normSchema s Union l f -> flip Union f <$> traverse normSchema l r@Record{name = tn} -> do - let sn = shortName tn - modify' (M.insert sn (NamedType tn)) + modify' (M.insert tn (NamedType tn)) flds <- mapM (\fld -> setType fld <$> normSchema (fldType fld)) (fields r) pure $ r { fields = flds } s -> pure s where - shortName tn = TN $ T.takeWhileEnd (/='.') (unTN tn) setType fld t = fld { fldType = t} - fullName s = TN $ maybe (typeName s) (\n -> typeName s <> "." <> n) (namespace s) diff --git a/src/Data/Avro/FromAvro.hs b/src/Data/Avro/FromAvro.hs --- a/src/Data/Avro/FromAvro.hs +++ b/src/Data/Avro/FromAvro.hs @@ -25,6 +25,7 @@ import qualified Data.Text.Lazy as TL import Data.Tagged import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U import Data.Word class HasAvroSchema a => FromAvro a where @@ -85,6 +86,14 @@ instance FromAvro a => FromAvro [a] where fromAvro (T.Array vec) = mapM fromAvro $ toList vec fromAvro v = badValue v "[a]" + +instance FromAvro a => FromAvro (V.Vector a) where + fromAvro (T.Array vec) = mapM fromAvro vec + fromAvro v = badValue v "Vector a" + +instance (U.Unbox a, FromAvro a) => FromAvro (U.Vector a) where + fromAvro (T.Array vec) = U.convert <$> mapM fromAvro vec + fromAvro v = badValue v "Unboxed Vector a" instance FromAvro Text where fromAvro (T.String txt) = pure txt diff --git a/src/Data/Avro/JSON.hs b/src/Data/Avro/JSON.hs --- a/src/Data/Avro/JSON.hs +++ b/src/Data/Avro/JSON.hs @@ -80,7 +80,7 @@ parseAvroJSON union env schema json where env = - Schema.buildTypeEnvironment missing schema . Schema.TN + Schema.buildTypeEnvironment missing schema missing name = fail ("Type " <> show name <> " not in schema") 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 @@ -1,8 +1,10 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -19,6 +21,7 @@ Schema, Type(..) , Field(..), Order(..) , TypeName(..) + , renderFullname , mkEnum, mkUnion , validateSchema -- * Lower level utilities @@ -33,12 +36,16 @@ , serializeBytes , parseAvroJSON + + , overlay + , subdefinition ) where import Control.Applicative import Control.Monad.Except import qualified Control.Monad.Fail as MF import Control.Monad.State.Strict + import Data.Aeson (FromJSON (..), ToJSON (..), object, (.!=), (.:), (.:!), (.:?), (.=)) import qualified Data.Aeson as A @@ -55,7 +62,7 @@ import qualified Data.List as L import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Monoid (First (..)) import Data.Semigroup import qualified Data.Set as S @@ -92,15 +99,13 @@ | Map { values :: Type } | NamedType TypeName -- Declared types - | Record { name :: TypeName - , namespace :: Maybe Text - , aliases :: [TypeName] - , doc :: Maybe Text - , order :: Maybe Order - , fields :: [Field] + | Record { name :: TypeName + , aliases :: [TypeName] + , doc :: Maybe Text + , order :: Maybe Order + , fields :: [Field] } | Enum { name :: TypeName - , namespace :: Maybe Text , aliases :: [TypeName] , doc :: Maybe Text , symbols :: [Text] @@ -109,39 +114,49 @@ | Union { options :: NonEmpty Type , unionLookup :: Int64 -> Maybe Type } - | Fixed { name :: TypeName - , namespace :: Maybe Text - , aliases :: [TypeName] - , size :: Int + | Fixed { name :: TypeName + , aliases :: [TypeName] + , size :: Int } deriving (Show) instance Eq Type where Null == Null = True Boolean == Boolean = True - Int == Int = True + Int == Int = True Long == Long = True Float == Float = True Double == Double = True Bytes == Bytes = True String == String = True + Array ty == Array ty2 = ty == ty2 Map ty == Map ty2 = ty == ty2 NamedType t == NamedType t2 = t == t2 - Record name1 ns1 _ _ _ fs1 == Record name2 ns2 _ _ _ fs2 = - and [name1 == name2, ns1 == ns2, fs1 == fs2] - Enum _ _ _ _ s _ == Enum _ _ _ _ s2 _ = s == s2 + + Record name1 _ _ _ fs1 == Record name2 _ _ _ fs2 = + and [name1 == name2, fs1 == fs2] + Enum name1 _ _ s _ == Enum name2 _ _ s2 _ = + and [name1 == name2, s == s2] Union a _ == Union b _ = a == b - Fixed _ _ _ s == Fixed _ _ _ s2 = s == s2 + Fixed name1 _ s == Fixed name2 _ s2 = + and [name1 == name2, s == s2] + _ == _ = False --- | @mkEnum name aliases namespace docs syms@ Constructs an `Enum` schema using --- the enumeration type's name, aliases (if any), namespace, documentation, and list of --- symbols that inhabit the enumeration. -mkEnum :: TypeName -> [TypeName] -> Maybe Text -> Maybe Text -> [Text] -> Type -mkEnum n as ns d ss = Enum n ns as d ss (\i -> IM.lookup (fromIntegral i) mp) - where - mp = IM.fromList (zip [0..] ss) +-- | Build an 'Enum' value from its components. +mkEnum :: TypeName + -- ^ The name of the enum (includes namespace). + -> [TypeName] + -- ^ Aliases for the enum (if any). + -> Maybe Text + -- ^ Optional documentation for the enum. + -> [Text] + -- ^ The symbols of the enum. + -> Type +mkEnum name aliases doc symbols = Enum name aliases doc symbols lookup + where lookup i = IM.lookup (fromIntegral i) table + table = IM.fromList $ [0..] `zip` symbols -- | @mkUnion subTypes@ Defines a union of the provided subTypes. N.B. it is -- invalid Avro to include another union or to have more than one of the same @@ -150,43 +165,123 @@ mkUnion os = Union os (\i -> IM.lookup (fromIntegral i) mp) where mp = IM.fromList (zip [0..] $ NE.toList os) -newtype TypeName = TN { unTN :: T.Text } +-- | A named type in Avro has a name and, optionally, a namespace. +-- +-- A name is a string that starts with an ASCII letter or underscore +-- followed by letters, underscores and digits: +-- +-- @ +-- name ::= [A-Za-z_][A-Za-z0-9_]* +-- @ +-- +-- Examples include @"_foo7"@, @"Bar_"@ and @"x"@. +-- +-- A namespace is a sequence of names with the same lexical +-- structure. When written as a string, the components of a namespace +-- are separated with dots (@"com.example"@). +-- +-- 'TypeName' represents a /fullname/—a name combined with a +-- namespace. These are written and parsed as dot-separated +-- strings. The 'TypeName' @TN "Foo" ["com", "example"]@ is rendered +-- as @"com.example.Foo"@. +-- +-- Fullnames have to be globally unique inside an Avro schema. +data TypeName = TN { baseName :: T.Text + , namespace :: [T.Text] + } deriving (Eq, Ord) +-- | Show the 'TypeName' as a string literal compatible with its +-- 'IsString' instance. instance Show TypeName where - show (TN s) = show s + show = show . renderFullname -instance Semigroup TypeName where - TN a <> TN b = TN (a <> b) +-- | Render a fullname as a dot separated string. +-- +-- @ +-- > renderFullname (TN "Foo" ["com", "example"]) +-- "com.example.Foo" +-- @ +renderFullname :: TypeName -> T.Text +renderFullname TN { baseName, namespace } = T.intercalate "." $ namespace <> [baseName] -instance Monoid TypeName where - mempty = TN mempty - mappend = (<>) +-- | Parses a fullname into a 'TypeName', assuming the string +-- representation is valid. +-- +-- @ +-- > parseFullname "com.example.Foo" +-- TN { baseName = "Foo", components = ["com", "example"] } +-- @ +parseFullname :: T.Text -> TypeName +parseFullname (T.splitOn "." -> components) = TN + { baseName = last components + , namespace = init components + } +-- | Build a type name out of the @name@ and @namespace@ fields of an +-- Avro record, enum or fixed definition. +-- +-- This follows the rules laid out in the Avro specification: +-- +-- 1. If the @"name"@ field contains dots, it is parsed as a +-- /fullname/ (see 'parseFullname') and the @"namespace"@ field is +-- ignored if present. +-- +-- 2. Otherwise, if both @"name"@ and @"namespace"@ fields are +-- present, they make up the /fullname/ +-- +-- 3. If only the @"name"@ field is specified, the @"namespace"@ is +-- inferred from the namespace of the most tightly enclosing schema +-- or protocol (the "context"). If there is no containing schema, the +-- namespace is null. +mkTypeName :: Maybe TypeName + -- ^ The name of the enclosing schema or protocol, if + -- any. This provides the context for inferring + -- namespaces. + -> Text + -- ^ The @"name"@ field of the definition. + -> Maybe Text + -- ^ The @"namespace"@ field of the definition, if + -- present. + -> TypeName + -- ^ The resulting /fullname/ of the generated type, + -- according to the rules laid out above. +mkTypeName context name ns + | isFullName name = parseFullname name + | otherwise = case ns of + Just ns -> TN name $ T.splitOn "." ns + Nothing -> TN name $ fromMaybe [] $ namespace <$> context + where isFullName = isJust . T.find (== '.') + +-- | This lets us write 'TypeName's as string literals in a fully +-- qualified style. @"com.example.foo"@ is the name @"foo"@ with the +-- namespace @"com.example"@; @"foo"@ is the name @"foo"@ with no +-- namespace. instance IsString TypeName where - fromString = TN . fromString + fromString = parseFullname . fromString instance Hashable TypeName where - hashWithSalt s (TN t) = hashWithSalt (hashWithSalt s ("AvroTypeName" :: Text)) t + hashWithSalt s (renderFullname -> name) = + hashWithSalt (hashWithSalt s ("AvroTypeName" :: Text)) name -- |Get the name of the type. In the case of unions, get the name of the -- first value in the union schema. typeName :: Type -> Text typeName bt = case bt of - Null -> "null" - Boolean -> "boolean" - Int -> "int" - Long -> "long" - Float -> "float" - Double -> "double" - Bytes -> "bytes" - String -> "string" - Array _ -> "array" - Map _ -> "map" - NamedType (TN t) -> t - Union (x:|_) _ -> typeName x - _ -> unTN $ name bt + Null -> "null" + Boolean -> "boolean" + Int -> "int" + Long -> "long" + Float -> "float" + Double -> "double" + Bytes -> "bytes" + String -> "string" + Array _ -> "array" + Map _ -> "map" + NamedType name -> renderFullname name + Union (x:|_) _ -> typeName x + _ -> renderFullname $ name bt data Field = Field { fldName :: Text , fldAliases :: [Text] @@ -201,135 +296,180 @@ deriving (Eq, Ord, Show) instance FromJSON Type where - parseJSON (A.String s) = - case s of - "null" -> return Null - "boolean" -> return Boolean - "int" -> return Int - "long" -> return Long - "float" -> return Float - "double" -> return Double - "bytes" -> return Bytes - "string" -> return String - somename -> return (NamedType (TN somename)) - parseJSON (A.Object o) = do - mbLogicalType <- o .:? ("logicalType" :: Text) :: Parser (Maybe Text) - ty <- o .: ("type" :: Text) + parseJSON = parseSchemaJSON Nothing - case mbLogicalType of +-- | A helper function that parses an Avro schema from JSON, resolving +-- namespaces based on context. +-- +-- See 'mkTypeName' for details on how namespaces are resolved. +parseSchemaJSON :: Maybe TypeName + -- ^ The name of the enclosing type of this schema, if + -- any. Used to resolve namespaces. + -> A.Value + -- ^ An Avro schema encoded in JSON. + -> Parser Schema +parseSchemaJSON context = \case + A.String s -> case s of + "null" -> return Null + "boolean" -> return Boolean + "int" -> return Int + "long" -> return Long + "float" -> return Float + "double" -> return Double + "bytes" -> return Bytes + "string" -> return String + somename -> return $ NamedType $ mkTypeName context somename Nothing + A.Array arr + | V.length arr > 0 -> + mkUnion . NE.fromList <$> mapM (parseSchemaJSON context) (V.toList arr) + | otherwise -> fail "Unions must have at least one type." + A.Object o -> do + logicalType :: Maybe Text <- o .:? "logicalType" + ty <- o .: "type" + + case logicalType of Just _ -> parseJSON (A.String ty) - Nothing -> - case ty of - "map" -> Map <$> o .: ("values" :: Text) - "array" -> Array <$> o .: ("items" :: Text) - "record" -> - Record <$> o .: ("name" :: Text) - <*> o .:? ("namespace" :: Text) - <*> o .:? ("aliases" :: Text) .!= [] - <*> o .:? ("doc" :: Text) - <*> o .:? ("order" :: Text) .!= Just Ascending - <*> o .: ("fields" :: Text) - "enum" -> - mkEnum <$> o .: ("name" :: Text) - <*> o .:? ("aliases" :: Text) .!= [] - <*> o .:? ("namespace" :: Text) - <*> o .:? ("doc" :: Text) - <*> o .: ("symbols" :: Text) - "fixed" -> - Fixed <$> o .: ("name" :: Text) - <*> o .:? ("namespace" :: Text) - <*> o .:? ("aliases" :: Text) .!= [] - <*> o .: ("size" :: Text) - s -> fail $ "Unrecognized object type: " <> T.unpack s - parseJSON (A.Array arr) | V.length arr > 0 = - mkUnion . NE.fromList <$> mapM parseJSON (V.toList arr) - parseJSON foo = typeMismatch "Invalid JSON for Avro Schema" foo + Nothing -> case ty of + "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" + order <- o .:? "order" .!= Just Ascending + fields <- mapM (parseField typeName) =<< o .: "fields" + pure $ Record typeName aliases doc order 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 + "fixed" -> 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 + s -> fail $ "Unrecognized object type: " <> T.unpack s -instance ToJSON Type where - toJSON bt = - case bt of - Null -> A.String "null" - Boolean -> A.String "boolean" - Int -> A.String "int" - Long -> A.String "long" - Float -> A.String "float" - Double -> A.String "double" - Bytes -> A.String "bytes" - String -> A.String "string" - Array tn -> object [ "type" .= ("array" :: Text), "items" .= tn ] - Map tn -> object [ "type" .= ("map" :: Text), "values" .= tn ] - NamedType (TN tn) -> A.String tn - Record {..} -> - let opts = catMaybes - [ ("order" .=) <$> order - , ("namespace" .=) <$> namespace - , ("doc" .=) <$> doc - ] - in object $ opts ++ - [ "type" .= ("record" :: Text) - , "name" .= name - , "aliases" .= aliases - , "fields" .= fields - ] - Enum {..} -> - let opts = catMaybes - [ ("namespace" .=) <$> namespace - , ("doc" .=) <$> doc - ] - in object $ opts ++ - [ "type" .= ("enum" :: Text) - , "name" .= name - , "aliases" .= aliases - , "symbols" .= symbols - ] - Union {..} -> A.Array $ V.fromList $ P.map toJSON (NE.toList options) - Fixed {..} -> - let opts = catMaybes - [ ("namespace" .=) <$> namespace ] - in object $ opts ++ - [ "type" .= ("fixed" :: Text) - , "name" .= name - , "aliases" .= aliases - , "size" .= size - ] + invalid -> typeMismatch "Invalid JSON for Avro Schema" invalid -instance ToJSON TypeName where - toJSON (TN t) = A.String t +-- | Parse aliases, inferring the namespace based on the type being aliases. +mkAliases :: TypeName + -- ^ The name of the type being aliased. + -> [Text] + -- ^ The aliases. + -> [TypeName] +mkAliases context = map $ \ name -> + mkTypeName (Just context) name Nothing -instance FromJSON TypeName where - parseJSON (A.String s) = return (TN s) - parseJSON j = typeMismatch "TypeName" j +-- | A helper function that parses field definitions, using the name +-- of the record for namespace resolution (see 'mkTypeName' for more +-- details). +parseField :: TypeName + -- ^ The name of the record this field belongs to. + -> A.Value + -- ^ The JSON object defining the field in the schema. + -> Parser Field +parseField record = \case + A.Object o -> do + name <- o .: "name" + doc <- o .:? "doc" + ty <- parseSchemaJSON (Just record) =<< o .: "type" + let err = fail "Haskell Avro bindings does not support default for aliased or recursive types at this time." + defM <- o .:! "default" + def <- case parseFieldDefault err ty <$> defM of + Just (Success x) -> return (Just x) + Just (Error e) -> fail e + Nothing -> return Nothing + order <- o .:? ("order" :: Text) .!= Just Ascending -instance FromJSON Field where - parseJSON (A.Object o) = - do nm <- o .: "name" - doc <- o .:? "doc" - ty <- o .: "type" - let err = fail "Haskell Avro bindings does not support default for aliased or recursive types at this time." - defM <- o .:! "default" - def <- case parseFieldDefault err ty <$> defM of - Just (Success x) -> return (Just x) - Just (Error e) -> fail e - Nothing -> return Nothing - od <- o .:? ("order" :: Text) .!= Just Ascending - al <- o .:? ("aliases" :: Text) .!= [] - return $ Field nm al doc od ty def + let mkAlias name = mkTypeName (Just record) name Nothing + aliases <- o .:? "aliases" .!= [] + return $ Field name aliases doc order ty def + invalid -> typeMismatch "Field" invalid - parseJSON j = typeMismatch "Field " j +instance ToJSON Type where + toJSON = schemaToJSON Nothing -instance ToJSON Field where - toJSON Field {..} = +-- | Serializes a 'Schema' to JSON. +-- +-- The optional name is used as the context for namespace +-- inference. If the context has the namespace @com.example@, then any +-- names in the @com.example@ namespace will be rendered without an +-- explicit namespace. +schemaToJSON :: Maybe TypeName + -- ^ The context used for keeping track of namespace + -- inference. + -> Schema + -- ^ The schema to serialize to JSON. + -> A.Value +schemaToJSON context = \case + Null -> A.String "null" + Boolean -> A.String "boolean" + Int -> A.String "int" + Long -> A.String "long" + Float -> A.String "float" + Double -> A.String "double" + Bytes -> A.String "bytes" + String -> A.String "string" + Array tn -> + object [ "type" .= ("array" :: Text), "items" .= schemaToJSON context tn ] + Map tn -> + object [ "type" .= ("map" :: Text), "values" .= schemaToJSON context tn ] + NamedType name -> toJSON $ render context name + Record {..} -> let opts = catMaybes - [ ("order" .=) <$> fldOrder - , ("doc" .=) <$> fldDoc - , ("default" .=) <$> fldDefault - ] - in object $ opts ++ - [ "name" .= fldName - , "type" .= fldType - , "aliases" .= fldAliases + [ ("order" .=) <$> order + , ("doc" .=) <$> doc + ] + in object $ opts ++ + [ "type" .= ("record" :: Text) + , "name" .= render context name + , "aliases" .= (render (Just name) <$> aliases) + , "fields" .= (fieldToJSON name <$> fields) + ] + Enum {..} -> + let opts = catMaybes [("doc" .=) <$> doc] + in object $ opts ++ + [ "type" .= ("enum" :: Text) + , "name" .= render context name + , "aliases" .= (render (Just name) <$> aliases) + , "symbols" .= symbols + ] + Union {..} -> toJSON $ schemaToJSON context <$> options + Fixed {..} -> + object [ "type" .= ("fixed" :: Text) + , "name" .= render context name + , "aliases" .= (render (Just name) <$> aliases) + , "size" .= size ] + where render context typeName + | Just ctx <- context + , namespace ctx == namespace typeName = baseName typeName + | otherwise = renderFullname typeName + fieldToJSON context Field {..} = + let opts = catMaybes + [ ("order" .=) <$> fldOrder + , ("doc" .=) <$> fldDoc + , ("default" .=) <$> fldDefault + ] + in object $ opts ++ + [ "name" .= fldName + , "type" .= schemaToJSON (Just context) fldType + , "aliases" .= fldAliases + ] + instance ToJSON (Ty.Value Type) where toJSON av = case av of @@ -387,7 +527,6 @@ (<>) = mplus instance Monoid (Result a) where mempty = fail "Empty Result" - mappend = mplus instance Foldable Result where foldMap _ (Error _) = mempty foldMap f (Success y) = f y @@ -400,7 +539,13 @@ -- | Field defaults are in the normal Avro JSON format except for -- unions. Default values for unions are specified as JSON encodings -- of the first type in the union. -parseFieldDefault :: (Text -> Maybe Type) -> Type -> A.Value -> Result (Ty.Value Type) +parseFieldDefault :: (TypeName -> Maybe Type) + -- ^ Lookup function for names defined in schema. + -> Schema + -- ^ The schema of the default value being parsed. + -> A.Value + -- ^ JSON encoding of an Avro value. + -> Result (Ty.Value Schema) parseFieldDefault env schema value = parseAvroJSON defaultUnion env schema value where defaultUnion (Union ts@(t :| _) _) val = Ty.Union ts t <$> parseFieldDefault env t val defaultUnion _ _ = error "Impossible: not Union." @@ -415,13 +560,13 @@ -- This function will only ever be passed 'Union' -- schemas. It /should/ error out if this is not the -- case—it represents a bug in this code. - -> (Text -> Maybe Type) + -> (TypeName -> Maybe Type) -> Type -> A.Value -> Result (Ty.Value Type) -parseAvroJSON union env (NamedType (TN tn)) av = - case env tn of - Nothing -> fail $ "Could not resolve type name for " <> show tn +parseAvroJSON union env (NamedType name) av = + case env name of + Nothing -> fail $ "Could not resolve type name for " <> T.unpack (renderFullname name) Just t -> parseAvroJSON union env t av parseAvroJSON union _ u@Union{} av = union u av parseAvroJSON union env ty av = @@ -521,31 +666,24 @@ validateSchema _sch = return () -- XXX TODO -- | @buildTypeEnvironment schema@ builds a function mapping type names to --- the types declared in the traversed schema. Notice this function does not --- currently handle namespaces in a correct manner, possibly allowing --- for bad environment lookups when used on complex schemas. -buildTypeEnvironment :: Applicative m => (TypeName -> m Type) -> Type -> TypeName -> m Type +-- the types declared in the traversed schema. +-- +-- This mapping includes both the base type names and any aliases they +-- have. Aliases and normal names are not differentiated in any way. +buildTypeEnvironment :: Applicative m + => (TypeName -> m Type) + -- ^ Callback to handle type names not in the + -- schema. + -> Schema + -- ^ The schema that we're generating a lookup + -- function for. + -> (TypeName -> m Type) buildTypeEnvironment failure from = - \forTy -> case HashMap.lookup forTy mp of - Nothing -> failure forTy - Just res -> pure res + \ forTy -> case HashMap.lookup forTy env of + Nothing -> failure forTy + Just res -> pure res where - mp = HashMap.fromList $ go from - go :: Type -> [(TypeName,Type)] - go ty = - let mk :: TypeName -> [TypeName] -> Maybe Text -> [(TypeName,Type)] - mk n as ns = - let unqual = n:as - qual = maybe [] (\x -> P.map (mappend (TN x <> ".")) unqual) ns - in zip (unqual ++ qual) (repeat ty) - in case ty of - Record {..} -> mk name aliases namespace ++ concatMap (go . fldType) fields - Enum {..} -> mk name aliases namespace - Union {..} -> concatMap go options - Fixed {..} -> mk name aliases namespace - Array {..} -> go item - Map {..} -> go values - _ -> [] + env = extractBindings from -- | Checks that two schemas match. This is like equality of schemas, -- except 'NamedTypes' match against other types /with the same name/. @@ -553,15 +691,63 @@ -- This extends recursively: two records match if they have the same -- name, the same number of fields and the fields all match. matches :: Type -> Type -> Bool -matches (NamedType (TN n)) t = n == typeName t -matches t (NamedType (TN n)) = typeName t == n +matches n@NamedType{} t = typeName n == typeName t +matches t n@NamedType{} = typeName t == typeName n matches (Array itemA) (Array itemB) = matches itemA itemB matches a@Record{} b@Record{} = and [ name a == name b - , namespace a == namespace b , length (fields a) == length (fields b) , and $ zipWith fieldMatches (fields a) (fields b) ] where fieldMatches = matches `on` fldType matches a@Union{} b@Union{} = and $ NE.zipWith matches (options a) (options b) matches t1 t2 = t1 == t2 + +-- | @extractBindings schema@ traverses a schema and builds a map of all declared +-- types. +-- +-- Types declared implicitly in record field definitions are also included. No distinction +-- is made between aliases and normal names. +extractBindings :: Type -> HashMap.HashMap TypeName Type +extractBindings = typeBindings HashMap.empty + where + insertAll :: (Eq k, Hashable k) => [k] -> v -> HashMap.HashMap k v -> HashMap.HashMap k v + insertAll keys value table = foldl (\hashmap key -> HashMap.insert key value hashmap) table keys + + fieldBindings :: HashMap.HashMap TypeName Type -> Field -> HashMap.HashMap TypeName Type + fieldBindings table Field{..} = typeBindings table fldType + + typeBindings :: HashMap.HashMap TypeName Type -> Type -> HashMap.HashMap TypeName Type + typeBindings table t@Record{..} = + let withRecord = insertAll (name : aliases) t table + in HashMap.unions $ map (fieldBindings withRecord) fields + typeBindings table e@Enum{..} = insertAll (name : aliases) e table + typeBindings table Union{..} = HashMap.unions $ NE.toList $ NE.map (typeBindings table) options + typeBindings table f@Fixed{..} = insertAll (name : aliases) f table + typeBindings table _ = table + +-- | Merge two schemas to produce a third. +-- Specifically, @overlay schema reference@ fills in 'NamedTypes' in 'schema' using any matching definitions from 'reference'. + +overlay :: Type -> Type -> Type +overlay input supplement = overlayType input + where + overlayField f@Field{..} = f { fldType = overlayType fldType } + 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{..} = u { + options = NE.map overlayType options, + unionLookup = \i -> case unionLookup i of + Just named@(NamedType _) -> Just $ rebind named + other -> other + } + overlayType nt@(NamedType _) = rebind nt + overlayType other = other + + rebind (NamedType tn) = HashMap.lookupDefault (NamedType tn) tn bindings + bindings = extractBindings supplement + +-- | Extract the named inner type definition as its own schema. +subdefinition :: Type -> Text -> Maybe Type +subdefinition schema name = mkTypeName Nothing name Nothing `HashMap.lookup` extractBindings schema diff --git a/src/Data/Avro/ToAvro.hs b/src/Data/Avro/ToAvro.hs --- a/src/Data/Avro/ToAvro.hs +++ b/src/Data/Avro/ToAvro.hs @@ -21,6 +21,7 @@ import qualified Data.Text.Lazy as TL import Data.Tagged import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U import Data.Word class HasAvroSchema a => ToAvro a where @@ -97,3 +98,8 @@ instance (ToAvro a) => ToAvro [a] where toAvro = T.Array . V.fromList . (toAvro <$>) +instance (ToAvro a) => ToAvro (V.Vector a) where + toAvro = T.Array . V.map toAvro + +instance (U.Unbox a, ToAvro a) => ToAvro (U.Vector a) where + toAvro = T.Array . V.map toAvro . U.convert diff --git a/test/Avro/Codec/ArraySpec.hs b/test/Avro/Codec/ArraySpec.hs --- a/test/Avro/Codec/ArraySpec.hs +++ b/test/Avro/Codec/ArraySpec.hs @@ -6,6 +6,8 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Text as T +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U import Test.Hspec import qualified Test.QuickCheck as Q @@ -19,3 +21,11 @@ it "map roundtrip" $ Q.property $ \(xs :: Map String Int) -> let xs' = M.mapKeys T.pack xs in decode (encode xs') == Success xs' + + it "vector roundtrip" $ Q.property $ \(xs :: [Int]) -> + let vec = V.fromList xs + in decode (encode vec) == Success vec + + it "unboxed vector roundtrip" $ Q.property $ \(xs :: [Int]) -> + let vec = U.fromList xs + in decode (encode vec) == Success vec diff --git a/test/Avro/Codec/BoolSpec.hs b/test/Avro/Codec/BoolSpec.hs --- a/test/Avro/Codec/BoolSpec.hs +++ b/test/Avro/Codec/BoolSpec.hs @@ -26,7 +26,7 @@ onlyBoolSchema :: Schema onlyBoolSchema = let fld nm = Field nm [] Nothing Nothing - in Record "OnlyBool" (Just "test.contract") [] Nothing Nothing + in Record "test.contract.OnlyBool" [] Nothing Nothing [ fld "onlyBoolValue" Boolean Nothing ] diff --git a/test/Avro/Codec/DoubleSpec.hs b/test/Avro/Codec/DoubleSpec.hs --- a/test/Avro/Codec/DoubleSpec.hs +++ b/test/Avro/Codec/DoubleSpec.hs @@ -20,7 +20,7 @@ onlyDoubleSchema :: Schema onlyDoubleSchema = let fld nm = Field nm [] Nothing Nothing - in Record "OnlyDouble" (Just "test.contract") [] Nothing Nothing + in Record "test.contract.OnlyDouble" [] Nothing Nothing [ fld "onlyDoubleValue" Double Nothing ] diff --git a/test/Avro/Codec/FloatSpec.hs b/test/Avro/Codec/FloatSpec.hs --- a/test/Avro/Codec/FloatSpec.hs +++ b/test/Avro/Codec/FloatSpec.hs @@ -20,7 +20,7 @@ onlyFloatSchema :: Schema onlyFloatSchema = let fld nm = Field nm [] Nothing Nothing - in Record "OnlyFloat" (Just "test.contract") [] Nothing Nothing + in Record "test.contract.OnlyFloat" [] Nothing Nothing [ fld "onlyFloatValue" Float Nothing ] diff --git a/test/Avro/Codec/Int64Spec.hs b/test/Avro/Codec/Int64Spec.hs --- a/test/Avro/Codec/Int64Spec.hs +++ b/test/Avro/Codec/Int64Spec.hs @@ -33,7 +33,7 @@ onlyInt64Schema :: Schema onlyInt64Schema = let fld nm = Field nm [] Nothing Nothing - in Record "OnlyInt64" (Just "test.contract") [] Nothing Nothing + in Record "test.contract.OnlyInt64" [] Nothing Nothing [ fld "onlyInt64Value" Long Nothing ] diff --git a/test/Avro/Codec/MaybeSpec.hs b/test/Avro/Codec/MaybeSpec.hs --- a/test/Avro/Codec/MaybeSpec.hs +++ b/test/Avro/Codec/MaybeSpec.hs @@ -23,7 +23,7 @@ onlyMaybeBoolSchema :: Schema onlyMaybeBoolSchema = let fld nm = Field nm [] Nothing Nothing - in Record "onlyMaybeBool" (Just "test.contract") [] Nothing Nothing + in Record "test.contract.onlyMaybeBool" [] Nothing Nothing [ fld "onlyMaybeBoolValue" (mkUnion (Null :| [Boolean])) Nothing ] diff --git a/test/Avro/Codec/NestedSpec.hs b/test/Avro/Codec/NestedSpec.hs --- a/test/Avro/Codec/NestedSpec.hs +++ b/test/Avro/Codec/NestedSpec.hs @@ -24,7 +24,7 @@ childTypeSchema :: Schema childTypeSchema = let fld nm = Field nm [] Nothing Nothing - in Record "ChildType" (Just "test.contract") [] Nothing Nothing + in Record "test.contract.ChildType" [] Nothing Nothing [ fld "childValue1" Long Nothing , fld "childValue2" Long Nothing ] @@ -32,7 +32,7 @@ parentTypeSchema :: Schema parentTypeSchema = let fld nm = Field nm [] Nothing Nothing - in Record "ParentType" (Just "test.contract") [] Nothing Nothing + in Record "test.contract.ParentType" [] Nothing Nothing [ fld "parentValue1" Long Nothing , fld "parentValue2" (Array childTypeSchema) Nothing] diff --git a/test/Avro/Codec/TextSpec.hs b/test/Avro/Codec/TextSpec.hs --- a/test/Avro/Codec/TextSpec.hs +++ b/test/Avro/Codec/TextSpec.hs @@ -6,6 +6,7 @@ import Data.Avro import Data.Avro.Schema import Data.Text +import qualified Data.ByteString.Lazy as BSL import Data.Tagged import Test.Hspec import qualified Data.Avro.Types as AT @@ -20,7 +21,7 @@ onlyTextSchema :: Schema onlyTextSchema = let fld nm = Field nm [] Nothing Nothing - in Record "OnlyText" (Just "test.contract") [] Nothing Nothing + in Record "test.contract.OnlyText" [] Nothing Nothing [ fld "onlyTextValue" String Nothing ] @@ -46,3 +47,10 @@ it "Can decode encoded Text values" $ do Q.property $ \(t :: String) -> decode (encode (OnlyText (pack t))) == Success (OnlyText (pack t)) + + it "Can process corrupted Text values without crashing" $ do + Q.property $ \bytes -> + let result = decode (BSL.pack bytes) :: Result Text + isSafeResult (Success _) = True + isSafeResult (Error _) = True + in result `shouldSatisfy` isSafeResult diff --git a/test/Avro/JSONSpec.hs b/test/Avro/JSONSpec.hs --- a/test/Avro/JSONSpec.hs +++ b/test/Avro/JSONSpec.hs @@ -10,6 +10,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Avro.Deriving +import Data.Avro.EitherN import Data.Avro.JSON import Test.Hspec @@ -67,18 +68,24 @@ let expected = EnumWrapper 37 "blarg" EnumReasonInstead parseJSON enumsExampleJSON `shouldBe` pure expected let unionsExampleA = Unions - { unionsScalars = Left "blarg" - , unionsNullable = Nothing - , unionsRecords = Left $ Foo { fooStuff = "stuff" } + { unionsScalars = Left "blarg" + , unionsNullable = Nothing + , unionsRecords = Left $ Foo { fooStuff = "stuff" } , unionsSameFields = Left $ Foo { fooStuff = "foo stuff" } + , unionsThree = E3_1 37 + , unionsFour = E4_2 "foo" + , unionsFive = E5_4 $ Foo { fooStuff = "foo stuff" } } unionsExampleB = Unions - { unionsScalars = Right 37 - , unionsNullable = Just 42 - , unionsRecords = Right $ Bar { barStuff = "stuff" + { unionsScalars = Right 37 + , unionsNullable = Just 42 + , unionsRecords = Right $ Bar { barStuff = "stuff" , barThings = Foo "things" } , unionsSameFields = Right $ NotFoo { notFooStuff = "not foo stuff" } + , unionsThree = E3_3 37 + , unionsFour = E4_4 $ Foo { fooStuff = "foo stuff" } + , unionsFive = E5_5 $ NotFoo { notFooStuff = "not foo stuff" } } it "should roundtrip (unions)" $ do forM_ [unionsExampleA, unionsExampleB] $ \ msg -> diff --git a/test/Avro/NamespaceSpec.hs b/test/Avro/NamespaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Avro/NamespaceSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} +module Avro.NamespaceSpec where + +import Control.Monad (forM_) + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS + +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (setEnv) + +import Test.Hspec + +import Paths_avro + +import Data.Avro.Schema + +spec :: Spec +spec = describe "NamespaceSpec.hs: namespace inference in Avro schemas" $ do + schemas <- runIO $ getFileName "test/data/namespace-inference.json" >>= LBS.readFile + let parsedSchemas :: [Schema] + Just parsedSchemas = Aeson.decode schemas + it "should infer namespaces correctly" $ do + forM_ parsedSchemas (`shouldBe` expected) + it "should generate JSON with namespaces inferred" $ do + -- the first schema in namespace-ifnerence.json is in the exact + -- format we expect to serialize Schema values + let expectedJSONSchema :: Aeson.Value + Just expectedJSONSchema = head <$> Aeson.decode schemas + Aeson.toJSON expected `shouldBe` expectedJSONSchema + +expected :: Schema +expected = Record + { name = "com.example.Foo" + , aliases = ["com.example.FooBar", "com.example.not.Bar"] + , doc = Just "An example schema to test namespace handling." + , order = Just Ascending + , fields = [field "bar" bar, field "baz" $ NamedType "com.example.baz.Baz"] + } + where field name schema = Field name [] Nothing (Just Ascending) schema Nothing + + bar = Record + { name = "com.example.Bar" + , aliases = ["com.example.Bar2", "com.example.not.Foo"] + , doc = Nothing + , order = Just Ascending + , fields = [ field "baz" baz + , field "bazzy" $ NamedType "com.example.Bazzy" + ] + } + + baz = Record + { name = "com.example.baz.Baz" + , aliases = ["com.example.Bazzy"] + , doc = Nothing + , order = Just Ascending + , fields = [ field "baz" $ NamedType "com.example.baz.Baz" + , field "bazzy" $ NamedType "com.example.Bazzy" + ] + } + +getFileName :: FilePath -> IO FilePath +getFileName p = do + path <- getDataFileName p + isOk <- doesFileExist path + pure $ if isOk then path else p diff --git a/test/Avro/NormSchemaSpec.hs b/test/Avro/NormSchemaSpec.hs --- a/test/Avro/NormSchemaSpec.hs +++ b/test/Avro/NormSchemaSpec.hs @@ -22,7 +22,7 @@ spec :: Spec spec = describe "Avro.NormSchemaSpec" $ do it "should have one full inner schema for each type" $ - (fldType <$> fields schema'ContainerChild) `shouldBe` [schema'ReusedChild, NamedType "ReusedChild"] + (fldType <$> fields schema'ContainerChild) `shouldBe` [schema'ReusedChild, NamedType "Boo.ReusedChild"] it "should normalise schemas from unions" $ fldType <$> fields schema'Curse `shouldBe` [mkUnion (Null :| [schema'Geo])] diff --git a/test/Avro/SchemaSpec.hs b/test/Avro/SchemaSpec.hs --- a/test/Avro/SchemaSpec.hs +++ b/test/Avro/SchemaSpec.hs @@ -7,7 +7,7 @@ import Data.Avro import Data.Avro.Deriving (makeSchema) -import Data.Avro.Schema (buildTypeEnvironment, matches) +import Data.Avro.Schema (overlay, matches) import Test.Hspec @@ -15,24 +15,10 @@ spec :: Spec spec = describe "Avro.SchemaSpec" $ do - describe "buildTypeEnvironment" $ - it "should contain definitions for all internal types" $ do - let schema = $(makeSchema "test/data/internal-bindings.avsc") - environment = buildTypeEnvironment err schema - err name = fail $ "Missing " ++ show name ++ " in environment." - expected = - [ "InternalBindings" - , "InField" - , "NestedInField" - , "AliasNestedInField" - , "NestedEnum" - , "NestedFixed" - , "InArray" - , "NestedInArray" - , "InMap" - , "NestedInMap" - , "InUnionA" - , "InUnionB" - ] - definitions <- traverse environment expected - length definitions `shouldBe` length expected + describe "overlay" $ + it "should support merging multiple schemas" $ do + let expected = $(makeSchema "test/data/overlay/expectation.avsc") + consumer = $(makeSchema "test/data/overlay/composite.avsc") + primitives = $(makeSchema "test/data/overlay/primitives.avsc") + + consumer `overlay` primitives `shouldSatisfy` matches expected diff --git a/test/Avro/THEnumSpec.hs b/test/Avro/THEnumSpec.hs --- a/test/Avro/THEnumSpec.hs +++ b/test/Avro/THEnumSpec.hs @@ -11,15 +11,14 @@ import Test.Hspec {-# ANN module ("HLint: ignore Redundant do" :: String) #-} - -deriveAvro "test/data/enums.avsc" +deriveAvroWithOptions (defaultDeriveOptions { namespaceBehavior = HandleNamespaces }) "test/data/enums.avsc" spec :: Spec spec = describe "Avro.THEnumSpec: Schema with enums" $ do it "should do roundtrip" $ do - let msg = EnumWrapper - { enumWrapperId = 42 - , enumWrapperName = "Text" - , enumWrapperReason = EnumReasonBecause + let msg = Haskell'avro'example'EnumWrapper + { haskell'avro'example'EnumWrapperId = 42 + , haskell'avro'example'EnumWrapperName = "Text" + , haskell'avro'example'EnumWrapperReason = Haskell'avro'example'EnumReasonBecause } fromAvro (toAvro msg) `shouldBe` pure msg diff --git a/test/Avro/THReusedSpec.hs b/test/Avro/THReusedSpec.hs --- a/test/Avro/THReusedSpec.hs +++ b/test/Avro/THReusedSpec.hs @@ -12,23 +12,24 @@ {-# ANN module ("HLint: ignore Redundant do" :: String) #-} -deriveAvro "test/data/reused.avsc" +deriveAvroWithOptions (defaultDeriveOptions { namespaceBehavior = HandleNamespaces }) "test/data/reused.avsc" spec :: Spec spec = describe "Avro.THReusedSpec: Schema with named types" $ do - let container = ContainerChild - { containerChildFstIncluded = ReusedChild 100 - , containerChildSndIncluded = ReusedChild 200 + let container = Boo'ContainerChild + { boo'ContainerChildFstIncluded = Boo'ReusedChild 100 + , boo'ContainerChildSndIncluded = Boo'ReusedChild 200 } - let wrapper = ReusedWrapper - { reusedWrapperFull = ReusedChild 42 - , reusedWrapperInner = container + let wrapper = Boo'ReusedWrapper + { boo'ReusedWrapperFull = Boo'ReusedChild 42 + , boo'ReusedWrapperInner = container } it "wrapper should do roundtrip" $ - fromAvro (toAvro wrapper) `shouldBe` pure wrapper + fromAvro (toAvro wrapper) `shouldBe` pure wrapper it "child should do rundtrip" $ - fromAvro (toAvro container) `shouldBe` pure container + fromAvro (toAvro container) `shouldBe` pure container it "innermost element should do roundtrip" $ - fromAvro (toAvro (ReusedChild 7)) `shouldBe` pure (ReusedChild 7) + fromAvro (toAvro (Boo'ReusedChild 7)) `shouldBe` pure (Boo'ReusedChild 7) + diff --git a/test/Avro/THUnionSpec.hs b/test/Avro/THUnionSpec.hs --- a/test/Avro/THUnionSpec.hs +++ b/test/Avro/THUnionSpec.hs @@ -10,6 +10,7 @@ import qualified Data.Aeson as Aeson import Data.Avro import Data.Avro.Deriving +import Data.Avro.EitherN import qualified Data.Avro.Schema as Schema import qualified Data.Avro.Types as Avro import qualified Data.ByteString.Lazy as LBS @@ -25,40 +26,52 @@ spec :: Spec spec = describe "Avro.THUnionSpec: Schema with unions." $ do let objA = Unions - { unionsScalars = Left "foo" - , unionsNullable = Nothing - , unionsRecords = Left $ Foo { fooStuff = "stuff" } + { unionsScalars = Left "foo" + , unionsNullable = Nothing + , unionsRecords = Left $ Foo { fooStuff = "stuff" } , unionsSameFields = Left $ Foo { fooStuff = "more stuff" } + , unionsThree = E3_1 37 + , unionsFour = E4_2 "foo" + , unionsFive = E5_4 $ Foo { fooStuff = "foo stuff" } } objB = Unions - { unionsScalars = Right 42 - , unionsNullable = Just 37 - , unionsRecords = Right $ Bar { barStuff = "stuff" - , barThings = Foo { fooStuff = "things" } - } + { unionsScalars = Right 42 + , unionsNullable = Just 37 + , unionsRecords = Right $ Bar { barStuff = "stuff" + , barThings = Foo { fooStuff = "things" } + } , unionsSameFields = Right $ NotFoo { notFooStuff = "different from Foo" } + , unionsThree = E3_3 37 + , unionsFour = E4_4 $ Foo { fooStuff = "foo stuff" } + , unionsFive = E5_5 $ NotFoo { notFooStuff = "not foo stuff" } } field name schema def = Schema.Field name [] Nothing (Just Schema.Ascending) schema def - record name namespace fields = - Schema.Record name namespace [] Nothing (Just Schema.Ascending) fields - named = Schema.NamedType . Schema.TN + record name fields = + Schema.Record name [] Nothing (Just Schema.Ascending) fields + named = Schema.NamedType - expectedSchema = record "Unions" (Just "haskell.avro.example") + foo = named "haskell.avro.example.Foo" + notFoo = named "haskell.avro.example.NotFoo" + expectedSchema = record "haskell.avro.example.Unions" [ field "scalars" (Schema.mkUnion (NE.fromList [Schema.String, Schema.Long])) scalarsDefault , field "nullable" (Schema.mkUnion (NE.fromList [Schema.Null, Schema.Int])) nullableDefault , field "records" (Schema.mkUnion (NE.fromList [fooSchema, barSchema])) Nothing - , field "sameFields" (Schema.mkUnion (NE.fromList [named "Foo", notFooSchema])) Nothing + , field "sameFields" (Schema.mkUnion (NE.fromList [foo, notFooSchema])) Nothing + + , field "three" (Schema.mkUnion (NE.fromList [Schema.Int, Schema.String, Schema.Long])) Nothing + , field "four" (Schema.mkUnion (NE.fromList [Schema.Int, Schema.String, Schema.Long, foo])) Nothing + , field "five" (Schema.mkUnion (NE.fromList [Schema.Int, Schema.String, Schema.Long, foo, notFoo])) Nothing ] scalarsDefault = Just $ Avro.Union (NE.fromList [Schema.String, Schema.Long]) Schema.String (Avro.String "foo") nullableDefault = Just $ Avro.Union (NE.fromList [Schema.Null, Schema.Int]) Schema.Null Avro.Null - fooSchema = record "Foo" Nothing [field "stuff" Schema.String Nothing] - barSchema = record "Bar" Nothing + fooSchema = record "haskell.avro.example.Foo" [field "stuff" Schema.String Nothing] + barSchema = record "haskell.avro.example.Bar" [ field "stuff" Schema.String Nothing - , field "things" (named "Foo") Nothing + , field "things" (named "haskell.avro.example.Foo") Nothing ] - notFooSchema = record "NotFoo" Nothing [field "stuff" Schema.String Nothing] + notFooSchema = record "haskell.avro.example.NotFoo" [field "stuff" Schema.String Nothing] unionsSchemaFile <- runIO $ getFileName "test/data/unions.avsc" >>= LBS.readFile let Just unionsSchemaFromJSON = Aeson.decode unionsSchemaFile diff --git a/test/Avro/ToAvroSpec.hs b/test/Avro/ToAvroSpec.hs --- a/test/Avro/ToAvroSpec.hs +++ b/test/Avro/ToAvroSpec.hs @@ -32,7 +32,7 @@ tmSchema :: Schema tmSchema = let fld nm = Field nm [] Nothing Nothing - in Record "TypesTestMessage" (Just "avro.haskell.test") [] Nothing Nothing + in Record "avro.haskell.test.TypesTestMessage" [] Nothing Nothing [ fld "id" Long Nothing , fld "name" String Nothing , fld "timestamp" (mkUnion (Null :| [Long])) Nothing diff --git a/test/Example1.hs b/test/Example1.hs --- a/test/Example1.hs +++ b/test/Example1.hs @@ -17,11 +17,11 @@ -- Schema's often come from an external JSON definition (.avsc files) or -- embedded in object files. meSchema :: Schema -meSchema = mkEnum "MyEnum" [] Nothing Nothing ["A","B","C","D"] +meSchema = mkEnum "MyEnum" [] Nothing ["A","B","C","D"] msSchema :: Schema msSchema = - Record "MyStruct" Nothing [] Nothing Nothing + Record "MyStruct" [] Nothing Nothing [ fld "enumOrString" eOrS (Just $ Ty.String "The Default") , fld "intvalue" Long Nothing ] diff --git a/test/data/internal-bindings.avsc b/test/data/internal-bindings.avsc deleted file mode 100644 --- a/test/data/internal-bindings.avsc +++ /dev/null @@ -1,105 +0,0 @@ -{ - "name" : "InternalBindings", - "type" : "record", - "doc" : "A test record that includes subdefinitions nested in different ways.", - "fields" : [ - { - "name" : "inField", - "doc" : "A record definition nested in a field of a record.", - "type" : { - "name" : "InField", - "type" : "record", - "fields" : [ - { - "name" : "nestedInField", - "doc" : "A record definition nested in two other records.", - "type" : { - "name" : "NestedInField", - "type" : "record", - "aliases" : ["AliasNestedInField"], - "fields" : [] - } - }, - { - "name" : "nestedEnum", - "doc" : "An enum definition nested in a nested record.", - "type" : { - "type" : "enum", - "name" : "NestedEnum", - "symbols" : ["Foo", "Bar"] - } - }, - { - "name" : "nestedFixed", - "doc" : "A fixed definition nested in a nested record.", - "type" : { - "type" : "fixed", - "size" : 42, - "name" : "NestedFixed" - } - } - ] - } - }, - { - "name" : "inArray", - "doc" : "A record definition nested in an array type.", - "type" : { - "type" : "array", - "items" : { - "name" : "InArray", - "type" : "record", - "fields" : [ - { - "name" : "nestedInArray", - "doc" : "A record definition nested inside a record defined in an array.", - "type" : { - "name" : "NestedInArray", - "type" : "record", - "fields" : [] - } - } - ] - } - } - }, - { - "name" : "inMap", - "doc" : "A record definition nested in a map type.", - "type" : { - "type" : "map", - "values" : { - "name" : "InMap", - "type" : "record", - "fields" : [ - { - "name" : "nestedInMap", - "doc" : "A record definition nested inside a record defined in a map.", - "type" : { - "name" : "NestedInMap", - "type" : "record", - "fields" : [] - } - } - ] - } - } - }, - { - "name" : "inUnion", - "doc" : "Record definitions nested in a union.", - "type" : [ - { - "name" : "InUnionA", - "type" : "record", - "fields" : [] - }, - { - "name" : "InUnionB", - "type" : "record", - "fields" : [] - } - ] - } - ] -} diff --git a/test/data/namespace-inference.json b/test/data/namespace-inference.json new file mode 100644 --- /dev/null +++ b/test/data/namespace-inference.json @@ -0,0 +1,154 @@ +[ + { + "type" : "record", + "name" : "com.example.Foo", + "aliases" : ["FooBar", "com.example.not.Bar"], + "doc" : "An example schema to test namespace handling.", + "order" : "ascending", + "fields" : [ + { + "name" : "bar", + "aliases" : [], + "order" : "ascending", + "type" : { + "type" : "record", + "name" : "Bar", + "order" : "ascending", + "aliases" : ["Bar2", "com.example.not.Foo"], + "fields" : [ + { + "name" : "baz", + "aliases" : [], + "order" : "ascending", + "type" : { + "type" : "record", + "order" : "ascending", + "name" : "com.example.baz.Baz", + "aliases" : ["com.example.Bazzy"], + "fields" : [ + { + "name" : "baz", + "type" : "Baz", + "aliases" : [], + "order" : "ascending" + }, + { + "name" : "bazzy", + "type" : "com.example.Bazzy", + "aliases" : [], + "order" : "ascending" + } + ] + } + }, + { + "name" : "bazzy", + "type" : "Bazzy", + "aliases" : [], + "order" : "ascending" + } + ] + } + }, + { + "name" : "baz", + "type" : "com.example.baz.Baz", + "aliases" : [], + "order" : "ascending" + } + ] + }, + { + "type" : "record", + "name" : "Foo", + "namespace" : "com.example", + "aliases" : ["FooBar", "com.example.not.Bar"], + "doc" : "An example schema to test namespace handling.", + "fields" : [ + { + "name" : "bar", + "namespace" : "com.example", + "type" : { + "type" : "record", + "name" : "Bar", + "aliases" : ["Bar2", "com.example.not.Foo"], + "fields" : [ + { + "name" : "baz", + "type" : { + "type" : "record", + "name" : "Baz", + "namespace" : "com.example.baz", + "aliases" : ["com.example.Bazzy"], + "fields" : [ + { + "name" : "baz", + "type" : "Baz" + }, + { + "name" : "bazzy", + "type" : "com.example.Bazzy" + } + ] + } + }, + { + "name" : "bazzy", + "type" : "Bazzy" + } + ] + } + }, + { + "name" : "baz", + "type" : "com.example.baz.Baz" + } + ] + }, + { + "type" : "record", + "name" : "com.example.Foo", + "namespace" : "should.be.ignored", + "aliases" : ["FooBar", "com.example.not.Bar"], + "doc" : "An example schema to test namespace handling.", + "fields" : [ + { + "name" : "bar", + "type" : { + "type" : "record", + "name" : "Bar", + "aliases" : ["Bar2", "com.example.not.Foo"], + "fields" : [ + { + "name" : "baz", + "type" : { + "type" : "record", + "name" : "com.example.baz.Baz", + "namespace" : "should.be.ignored", + "aliases" : ["com.example.Bazzy"], + "fields" : [ + { + "name" : "baz", + "type" : "Baz" + }, + { + "name" : "bazzy", + "type" : "com.example.Bazzy" + } + ] + } + }, + { + "name" : "bazzy", + "type" : "Bazzy" + } + ] + } + }, + { + "name" : "baz", + "type" : "com.example.baz.Baz" + } + ] + } +] diff --git a/test/data/unions-object-a.json b/test/data/unions-object-a.json --- a/test/data/unions-object-a.json +++ b/test/data/unions-object-a.json @@ -4,13 +4,18 @@ }, "nullable": null, "records": { - "Foo": { + "haskell.avro.example.Foo": { "stuff": "stuff" } }, "sameFields": { - "Foo": { + "haskell.avro.example.Foo": { "stuff": "foo stuff" } + }, + "three": { "int": 37 }, + "four": { "string": "foo" }, + "five": { + "haskell.avro.example.Foo": { "stuff": "foo stuff" } } } diff --git a/test/data/unions-object-b.json b/test/data/unions-object-b.json --- a/test/data/unions-object-b.json +++ b/test/data/unions-object-b.json @@ -6,7 +6,7 @@ "int": 42 }, "records": { - "Bar": { + "haskell.avro.example.Bar": { "stuff": "stuff", "things": { "stuff": "things" @@ -14,8 +14,15 @@ } }, "sameFields": { - "NotFoo": { + "haskell.avro.example.NotFoo": { "stuff": "not foo stuff" } + }, + "three": { "long": 37 }, + "four": { + "haskell.avro.example.Foo": { "stuff" : "foo stuff" } + }, + "five": { + "haskell.avro.example.NotFoo": { "stuff": "not foo stuff" } } } diff --git a/test/data/unions.avsc b/test/data/unions.avsc --- a/test/data/unions.avsc +++ b/test/data/unions.avsc @@ -43,6 +43,9 @@ ] } ] - } + }, + { "name" : "three", "type" : ["int", "string", "long"] }, + { "name" : "four", "type" : ["int", "string", "long", "Foo"] }, + { "name" : "five", "type" : ["int", "string", "long", "Foo", "NotFoo"] } ] }