diff --git a/mu-avro.cabal b/mu-avro.cabal --- a/mu-avro.cabal +++ b/mu-avro.cabal @@ -1,5 +1,5 @@ name: mu-avro -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Avro serialization support for Mu microservices description: You can use @mu-avro@ to read AVRO Schema Declarations for mu-haskell @@ -28,23 +28,24 @@ Mu.Quasi.Avro.Example build-depends: - aeson - , avro >=0.5.1 - , base >=4.12 && <5 - , bytestring - , containers - , deepseq - , language-avro >=0.1.3.1 - , mu-rpc >=0.3.0 - , mu-schema >=0.3.0 - , sop-core - , tagged - , template-haskell >=2.12 - , text - , time - , unordered-containers - , uuid - , vector + aeson >=1.4 && <2 + , avro >=0.5.1 && <0.6 + , base >=4.12 && <5 + , bytestring >=0.10 && <0.11 + , containers >=0.6 && <0.7 + , deepseq >=1.4 && <2 + , language-avro >=0.1.3 && <0.2 + , mu-rpc ==0.4.* + , mu-schema ==0.3.* + , sop-core >=0.5.0 && <0.6 + , tagged >=0.8.6 && <0.9 + , template-haskell >=2.14 && <2.16 + , text >=1.2 && <2 + , time >=1.9 && <2 + , transformers >=0.5 && <0.6 + , unordered-containers >=0.2 && <0.3 + , uuid >=1.3 && <2 + , vector >=0.12 && <0.13 hs-source-dirs: src default-language: Haskell2010 @@ -53,11 +54,11 @@ executable test-avro main-is: Avro.hs build-depends: - avro >=0.5 + avro >=0.5.1 && <0.6 , base >=4.12 && <5 - , bytestring - , mu-avro >=0.3.0 - , mu-schema >=0.3.0 + , bytestring >=0.10 && <0.11 + , mu-avro + , mu-schema ==0.3.* hs-source-dirs: test default-language: Haskell2010 diff --git a/src/Mu/Adapter/Avro.hs b/src/Mu/Adapter/Avro.hs --- a/src/Mu/Adapter/Avro.hs +++ b/src/Mu/Adapter/Avro.hs @@ -21,7 +21,6 @@ -} module Mu.Adapter.Avro () where -import Control.Applicative ((<|>)) import Control.Arrow ((***)) import qualified Data.Avro as A import qualified Data.Avro.Encoding.FromAvro as AVal @@ -30,11 +29,11 @@ import qualified Data.Avro.Schema.Schema as ASch -- 'Tagged . unTagged' can be replaced by 'coerce' -- eliminating some run-time overhead +import Control.Monad.Trans.State import Data.Avro.EitherN (putIndexedValue) import Data.ByteString.Builder (Builder, word8) import Data.Coerce (coerce) import qualified Data.HashMap.Strict as HM -import Data.List ((\\)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmptyList import qualified Data.Map as M @@ -51,8 +50,9 @@ toSchemalessTerm (AVal.Record s r) = case s of RSch.Record { RSch.fields = fs } - -> SLess.TRecord $ map (\(k,v) -> SLess.Field k (SLess.toSchemalessValue v)) - $ zip (map RSch.fldName fs) (V.toList r) + -> SLess.TRecord $ + zipWith (\k v -> SLess.Field k (SLess.toSchemalessValue v)) + (map RSch.fldName fs) (V.toList r) _ -> error ("this should never happen:\n" ++ show s) toSchemalessTerm (AVal.Enum _ i _) = SLess.TEnum i @@ -83,148 +83,118 @@ toSchemalessValue e@AVal.Enum {} = SLess.FSchematic (SLess.toSchemalessTerm e) -instance (HasAvroSchemas sch sch) +instance (HasAvroSchema' (Term sch (sch :/: sty))) => A.HasAvroSchema (WithSchema sch sty t) where - schema = Tagged $ ASch.Union $ schemas (Proxy @sch) (Proxy @sch) ts - where ts = typeNames (Proxy @sch) (Proxy @sch) + schema = coerce $ evalState (schema' @(Term sch (sch :/: sty))) [] instance ( FromSchema sch sty t , A.FromAvro (Term sch (sch :/: sty)) ) => A.FromAvro (WithSchema sch sty t) where - fromAvro entire@(AVal.Union _ _ v) - = -- remove first layer of union - WithSchema . fromSchema' @_ @_ @sch <$> AVal.fromAvro v - <|> -- try with the entire thing - WithSchema . fromSchema' @_ @_ @sch <$> AVal.fromAvro entire fromAvro entire - = WithSchema . fromSchema' @_ @_ @sch <$> AVal.fromAvro entire + = WithSchema . fromSchema' @_ @_ @sch <$> AVal.fromAvro entire instance ( ToSchema sch sty t - , A.ToAvro (Term sch (sch :/: sty)) - , KnownNat (IxOf sch sty) ) + , A.ToAvro (Term sch (sch :/: sty)) ) => A.ToAvro (WithSchema sch sty t) where - toAvro (ASch.Union vs) (WithSchema v) - = putIndexedValue (fromInteger $ natVal (Proxy @(IxOf sch sty))) - vs - (toSchema' @_ @_ @sch v) - toAvro s _ = error ("this should never happen:\n" ++ show s) - -class HasAvroSchemas (r :: Schema tn fn) (sch :: Schema tn fn) where - schemas :: Proxy r -> Proxy sch -> [ASch.TypeName] -> V.Vector ASch.Schema - typeNames :: Proxy r -> Proxy sch -> [ASch.TypeName] -instance HasAvroSchemas r '[] where - schemas _ _ _ = V.empty - typeNames _ _ = [] -instance forall r d ds. - (HasAvroSchema' (Term r d), HasAvroSchemas r ds) - => HasAvroSchemas r (d ': ds) where - schemas pr _ tys = V.cons thisSchema (schemas pr (Proxy @ds) tys) - where thisSchema = unTagged $ schema' @(Term r d) (tys \\ typeName' (Proxy @(Term r d))) - typeNames pr _ = typeName' (Proxy @(Term r d)) ++ typeNames pr (Proxy @ds) - -type family IxOf (sch :: Schema tn fn) (sty :: tn) :: Nat where - IxOf ('DRecord nm fs ': rest) nm = 0 - IxOf ('DEnum nm cs ': rest) nm = 0 - IxOf (other ': rest) nm = 1 + IxOf rest nm + toAvro sch (WithSchema v) + = A.toAvro sch (toSchema' @_ @_ @sch v) -- HasAvroSchema instances class HasAvroSchema' x where - typeName' :: Proxy x -> [ASch.TypeName] - schema' :: [ASch.TypeName] -> Tagged x ASch.Schema + schema' :: State [ASch.TypeName] (Tagged x ASch.Schema) instance TypeError ('Text "you should never use HasAvroSchema directly on Term, use WithSchema") => A.HasAvroSchema (Term sch t) where schema = error "this should never happen" instance HasAvroSchema' (FieldValue sch t) => A.HasAvroSchema (FieldValue sch t) where - schema = schema' [] + schema = evalState schema' [] instance (KnownName name, HasAvroSchemaFields sch args) => HasAvroSchema' (Term sch ('DRecord name args)) where - typeName' _ = [nameTypeName (Proxy @name)] - schema' visited - = if recordName `elem` visited - then Tagged $ ASch.NamedType recordName - else Tagged $ ASch.Record recordName [] Nothing fields - where recordName = nameTypeName (Proxy @name) - fields = schemaF (Proxy @sch) (Proxy @args) visited + schema' + = do let recordName = nameTypeName (Proxy @name) + visited <- gets (recordName `elem`) + if visited + then pure $ Tagged $ ASch.NamedType recordName + else do modify (recordName :) + fields <- schemaF (Proxy @sch) (Proxy @args) + pure $ Tagged $ ASch.Record recordName [] Nothing fields instance (KnownName name, HasAvroSchemaEnum choices) => HasAvroSchema' (Term sch ('DEnum name choices)) where - typeName' _ = [nameTypeName (Proxy @name)] - schema' visited - = if enumName `elem` visited - then Tagged $ ASch.NamedType enumName - else Tagged $ ASch.mkEnum enumName [] Nothing choicesNames - where enumName = nameTypeName (Proxy @name) - choicesNames = schemaE (Proxy @choices) + schema' + = do let enumName = nameTypeName (Proxy @name) + choicesNames = schemaE (Proxy @choices) + visited <- gets (enumName `elem`) + if visited + then pure $ Tagged $ ASch.NamedType enumName + else do modify (enumName :) + pure $ Tagged $ ASch.mkEnum enumName [] Nothing choicesNames + instance HasAvroSchema' (FieldValue sch t) => HasAvroSchema' (Term sch ('DSimple t)) where - typeName' _ = [] - schema' visited = coerce $ schema' @(FieldValue sch t) visited + schema' = coerce <$> schema' @(FieldValue sch t) instance HasAvroSchema' (FieldValue sch 'TNull) where - typeName' _ = [] - schema' _ = Tagged ASch.Null + schema' = pure $ Tagged ASch.Null instance A.HasAvroSchema t => HasAvroSchema' (FieldValue sch ('TPrimitive t)) where - typeName' _ = [] - schema' _ = coerce $ A.schema @t + schema' = pure $ coerce $ A.schema @t instance (HasAvroSchema' (Term sch (sch :/: t))) => HasAvroSchema' (FieldValue sch ('TSchematic t)) where - typeName' _ = [] - schema' visited = coerce $ schema' @(Term sch (sch :/: t)) visited + schema' = coerce <$> schema' @(Term sch (sch :/: t)) instance forall sch choices. HasAvroSchemaUnion (FieldValue sch) choices => HasAvroSchema' (FieldValue sch ('TUnion choices)) where - typeName' _ = [] - schema' visited - = Tagged $ ASch.mkUnion $ schemaU (Proxy @(FieldValue sch)) (Proxy @choices) visited + schema' = do + schs <- schemaU (Proxy @(FieldValue sch)) (Proxy @choices) + pure $ Tagged $ ASch.mkUnion schs instance HasAvroSchema' (FieldValue sch t) => HasAvroSchema' (FieldValue sch ('TOption t)) where - typeName' _ = [] - schema' visited - = Tagged $ ASch.mkUnion $ ASch.Null :| [iSchema] - where iSchema = unTagged $ schema' @(FieldValue sch t) visited + schema' = do + iSchema <- unTagged <$> schema' @(FieldValue sch t) + pure $ Tagged $ ASch.mkUnion $ ASch.Null :| [iSchema] instance HasAvroSchema' (FieldValue sch t) => HasAvroSchema' (FieldValue sch ('TList t)) where - typeName' _ = [] - schema' visited - = Tagged $ ASch.Array iSchema - where iSchema = unTagged $ schema' @(FieldValue sch t) visited + schema' = do + iSchema <- unTagged <$> schema' @(FieldValue sch t) + pure $ Tagged $ ASch.Array iSchema -- These are the only two versions of Map supported by the library instance HasAvroSchema' (FieldValue sch v) => HasAvroSchema' (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where - typeName' _ = [] - schema' visited - = Tagged $ ASch.Map iSchema - where iSchema = unTagged $ schema' @(FieldValue sch v) visited + schema' = do + iSchema <- unTagged <$> schema' @(FieldValue sch v) + pure $ Tagged $ ASch.Map iSchema instance HasAvroSchema' (FieldValue sch v) => HasAvroSchema' (FieldValue sch ('TMap ('TPrimitive String) v)) where - typeName' _ = [] - schema' visited - = Tagged $ ASch.Map iSchema - where iSchema = unTagged $ schema' @(FieldValue sch v) visited + schema' = do + iSchema <- unTagged <$> schema' @(FieldValue sch v) + pure $ Tagged $ ASch.Map iSchema class HasAvroSchemaUnion (f :: k -> *) (xs :: [k]) where - schemaU :: Proxy f -> Proxy xs -> [ASch.TypeName] -> NonEmpty ASch.Schema + schemaU :: Proxy f -> Proxy xs -> State [ASch.TypeName] (NonEmpty ASch.Schema) instance HasAvroSchema' (f v) => HasAvroSchemaUnion f '[v] where - schemaU _ _ visited = vSchema :| [] - where vSchema = unTagged (schema' @(f v) visited) + schemaU _ _ = do + vSchema <- unTagged <$> schema' @(f v) + pure $ vSchema :| [] instance (HasAvroSchema' (f x), HasAvroSchemaUnion f (y ': zs)) => HasAvroSchemaUnion f (x ': y ': zs) where - schemaU p _ visited = xSchema :| NonEmptyList.toList yzsSchema - where xSchema = unTagged (schema' @(f x) visited) - yzsSchema = schemaU p (Proxy @(y ': zs)) visited + schemaU p _ = do + xSchema <- unTagged <$> schema' @(f x) + yzsSchema <- schemaU p (Proxy @(y ': zs)) + pure $ xSchema :| NonEmptyList.toList yzsSchema class HasAvroSchemaFields sch (fs :: [FieldDef tn fn]) where - schemaF :: Proxy sch -> Proxy fs -> [ASch.TypeName] -> [ASch.Field] + schemaF :: Proxy sch -> Proxy fs -> State [ASch.TypeName] [ASch.Field] instance HasAvroSchemaFields sch '[] where - schemaF _ _ _ = [] + schemaF _ _ = pure [] instance (KnownName name, HasAvroSchema' (FieldValue sch t), HasAvroSchemaFields sch fs) => HasAvroSchemaFields sch ('FieldDef name t ': fs) where - schemaF psch _ visited = schemaThis : schemaF psch (Proxy @fs) visited - where fieldName = nameText (Proxy @name) - schemaT = unTagged $ schema' @(FieldValue sch t) visited - schemaThis = ASch.Field fieldName [] Nothing Nothing schemaT Nothing + schemaF psch _ = do + let fieldName = nameText (Proxy @name) + schemaT <- unTagged <$> schema' @(FieldValue sch t) + let schemaThis = ASch.Field fieldName [] Nothing Nothing schemaT Nothing + rest <- schemaF psch (Proxy @fs) + pure $ schemaThis : rest class HasAvroSchemaEnum (fs :: [ChoiceDef fn]) where schemaE :: Proxy fs -> [T.Text] @@ -317,7 +287,8 @@ = A.record s $ toAvroF fields -- if we don't have a record, fall back to the one from schema toAvro _ (TRecord fields) - = A.record (unTagged $ schema' @(Term sch ('DRecord name args)) []) $ toAvroF fields + = A.record sch (toAvroF fields) + where sch = unTagged $ evalState (schema' @(Term sch ('DRecord name args))) [] instance (KnownName name, ToAvroEnum choices, HasAvroSchemaEnum choices) => A.ToAvro (Term sch ('DEnum name choices)) where toAvro ASch.Enum { ASch.symbols = ss } (TEnum n) diff --git a/src/Mu/Quasi/Avro.hs b/src/Mu/Quasi/Avro.hs --- a/src/Mu/Quasi/Avro.hs +++ b/src/Mu/Quasi/Avro.hs @@ -1,4 +1,5 @@ {-# language DataKinds #-} +{-# language KindSignatures #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} @@ -39,6 +40,7 @@ import Data.Time.Millis import Data.UUID import qualified Data.Vector as V +import GHC.TypeLits import Language.Avro.Parser import qualified Language.Avro.Types as A import Language.Haskell.TH @@ -88,12 +90,12 @@ schemaDec <- tySynD schemaName' [] (schemaFromAvro $ S.toList (A.types protocol)) serviceDec <- tySynD serviceName' [] [t| 'Package $(pkgType (A.ns protocol)) - '[ 'Service $(textToStrLit (A.pname protocol)) '[] + '[ 'Service $(textToStrLit (A.pname protocol)) $(typesToList <$> mapM (avroMethodToType schemaName') (S.toList $ A.messages protocol)) ] |] pure [schemaDec, serviceDec] where - pkgType Nothing = [t| 'Nothing |] + pkgType Nothing = [t| ('Nothing :: Maybe Symbol) |] pkgType (Just (A.Namespace p)) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |] @@ -176,13 +178,13 @@ avroMethodToType :: Name -> A.Method -> Q Type avroMethodToType schemaName m - = [t| 'Method $(textToStrLit (A.mname m)) '[] + = [t| 'Method $(textToStrLit (A.mname m)) $(typesToList <$> mapM argToType (A.args m)) $(retToType (A.result m)) |] where argToType :: A.Argument -> Q Type argToType (A.Argument (A.NamedType a) _) - = [t| 'ArgSingle 'Nothing '[] ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |] + = [t| 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |] argToType (A.Argument _ _) = fail "only named types may be used as arguments" @@ -195,7 +197,7 @@ = fail "only named types may be used as results" typesToList :: [Type] -> Type -typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT +typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT textToStrLit :: T.Text -> Q Type textToStrLit s = litT $ strTyLit $ T.unpack s diff --git a/src/Mu/Quasi/Avro/Example.hs b/src/Mu/Quasi/Avro/Example.hs --- a/src/Mu/Quasi/Avro/Example.hs +++ b/src/Mu/Quasi/Avro/Example.hs @@ -1,6 +1,9 @@ -{-# language CPP #-} -{-# language DataKinds #-} -{-# language QuasiQuotes #-} +{-# language CPP #-} +{-# language DataKinds #-} +{-# language KindSignatures #-} +{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} + {-| Description : Examples for Avro quasi-quoters @@ -8,7 +11,7 @@ -} module Mu.Quasi.Avro.Example where -import Mu.Quasi.Avro (avro, avroFile) +import Mu.Quasi.Avro (avdl, avro, avroFile) type Example = [avro| { @@ -44,4 +47,10 @@ type ExampleFromFile = [avroFile|adapter/avro/test/avro/example.avsc|] #else type ExampleFromFile = [avroFile|test/avro/example.avsc|] +#endif + +#if __GHCIDE__ +avdl "ExampleProtocol" "ExampleService" "." "adapter/avro/test/avro/example.avdl" +#else +avdl "ExampleProtocol" "ExampleService" "." "test/avro/example.avdl" #endif diff --git a/test/avro/example.avsc b/test/avro/example.avsc --- a/test/avro/example.avsc +++ b/test/avro/example.avsc @@ -1,23 +1,23 @@ -[ { "type": "enum", - "name": "gender", - "symbols" : ["male", "female", "nb"] - } -, { "type": "record" - , "name": "address" - , "fields": [ - {"name": "postcode", "type": "string"}, - {"name": "country", "type": "string"} - ] - } -,{ "type": "record", - "name": "person", - "fields": [ - {"name": "firstName", "type": "string"}, - {"name": "lastName", "type": "string"}, - {"name": "age", "type": ["long", "null"]}, - {"name": "gender", "type": ["gender", "null"]}, - {"name": "address", "type": "address"}, - {"name": "lucky_numbers", "type": { "type": "array", "items": "long" } } - ] - } -] +{ "type": "record", + "name": "person", + "fields": [ + {"name": "firstName", "type": "string"}, + {"name": "lastName", "type": "string"}, + {"name": "age", "type": ["long", "null"]}, + {"name": "gender", "type": [ + { "type": "enum", + "name": "gender", + "symbols" : ["male", "female", "nb"] + } , "null"]}, + {"name": "address", "type": + { "type": "record" + , "name": "address" + , "fields": [ + {"name": "postcode", "type": "string"}, + {"name": "country", "type": "string"} + ] + } + }, + {"name": "lucky_numbers", "type": { "type": "array", "items": "long" } } + ] +}