diff --git a/mu-avro.cabal b/mu-avro.cabal --- a/mu-avro.cabal +++ b/mu-avro.cabal @@ -1,51 +1,64 @@ -cabal-version: >=1.10 -name: mu-avro -version: 0.1.0.0 -synopsis: Avro serialization support for Mu microservices -description: You can use @mu-avro@ to read AVRO Schema Declarations for mu-haskell -license: Apache-2.0 -license-file: LICENSE -author: Alejandro Serrano, Flavio Corpa -maintainer: alejandro.serrano@47deg.com -copyright: Copyright © 2019-2020 -category: Network -build-type: Simple -data-files: test/avro/*.avsc -homepage: https://higherkindness.io/mu-haskell/ -bug-reports: https://github.com/higherkindness/mu-haskell/issues +name: mu-avro +version: 0.2.0.0 +synopsis: Avro serialization support for Mu microservices +description: + You can use @mu-avro@ to read AVRO Schema Declarations for mu-haskell +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +data-files: test/avro/*.avsc +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + source-repository head type: git location: https://github.com/higherkindness/mu-haskell library - exposed-modules: Mu.Adapter.Avro - , Mu.Quasi.Avro - , Mu.Quasi.Avro.Example - build-depends: base >=4.12 && <5 - , mu-schema - , avro - , tagged - , aeson - , text - , vector - , containers - , unordered-containers - , sop-core - , bytestring - , template-haskell >= 2.12 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - -fprint-potential-instances + exposed-modules: + Data.Time.Millis + Mu.Adapter.Avro + Mu.Quasi.Avro + Mu.Quasi.Avro.Example + build-depends: + aeson + , avro >=0.4.7 + , base >=4.12 && <5 + , bytestring + , containers + , deepseq + , language-avro >=0.1.2 + , mu-rpc >=0.2.0 + , mu-schema >=0.2.0 + , sop-core + , tagged + , template-haskell >=2.12 + , text + , time + , unordered-containers + , uuid + , vector + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + executable test-avro - main-is: Avro.hs - build-depends: base >=4.12 && <5 - , mu-schema - , mu-avro - , avro - , bytestring - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall + main-is: Avro.hs + build-depends: + avro >=0.4.7 + , base >=4.12 && <5 + , bytestring + , mu-avro >=0.2.0 + , mu-schema >=0.2.0 + + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Data/Time/Millis.hs b/src/Data/Time/Millis.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Millis.hs @@ -0,0 +1,41 @@ +{-# language GeneralizedNewtypeDeriving #-} +module Data.Time.Millis where + + +import Control.DeepSeq (NFData) +import Data.Avro.Encode +import Data.Avro.EncodeRaw +import Data.Avro.FromAvro +import Data.Avro.HasAvroSchema +import Data.Avro.Schema as S +import Data.Avro.ToAvro +import Data.Avro.Types as T +import Data.Tagged +import Data.Time +import Unsafe.Coerce + +-- | Wrapper for time difference expressed in milliseconds +newtype DiffTimeMs = DiffTimeMs { unDiffTimeMs :: DiffTime } + deriving (Show, Eq, Ord, Enum, Num, Fractional, Real, RealFrac, NFData) + +instance EncodeAvro DiffTimeMs where + avro d + -- Unfortunately, the AvroM constructor is not exposed :( + = unsafeCoerce ( encodeRaw (fromIntegral $ diffTimeToMillis d :: Int) + , S.Long (Just TimeMicros) ) + +instance HasAvroSchema DiffTimeMs where + schema = Tagged $ S.Int (Just TimeMillis) + +instance ToAvro DiffTimeMs where + toAvro = T.Int . fromIntegral . diffTimeToMillis + +instance FromAvro DiffTimeMs where + fromAvro (T.Int v) = pure $ millisToDiffTime (toInteger v) + fromAvro v = badValue v "TimeMicros" + +diffTimeToMillis :: DiffTimeMs -> Integer +diffTimeToMillis = (`div` 1000000000) . diffTimeToPicoseconds . unDiffTimeMs + +millisToDiffTime :: Integer -> DiffTimeMs +millisToDiffTime = DiffTimeMs . picosecondsToDiffTime . (* 1000000000) 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 @@ -1,3 +1,4 @@ +{-# language ConstraintKinds #-} {-# language DataKinds #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} @@ -72,97 +73,105 @@ toSchemalessValue e@AVal.Enum {} = SLess.FSchematic (SLess.toSchemalessTerm e) -instance HasAvroSchemas sch sch +instance A.HasAvroSchema (Term f sch (sch :/: sty)) => A.HasAvroSchema (WithSchema f sch sty t) where - -- the previous iteration added only the schema of the type - -- schema = coerce $ A.schema @(Term sch (sch :/: sty)) - -- but now we prefer to have all of them - schema = Tagged $ ASch.Union (schemas (Proxy @sch) (Proxy @sch)) -instance ( FromSchema f sch sty t, HasAvroSchemas sch sch + schema = coerce $ A.schema @(Term f sch (sch :/: sty)) +instance ( FromSchema f sch sty t , A.FromAvro (Term f sch (sch :/: sty)) ) => A.FromAvro (WithSchema f sch sty t) where - fromAvro (AVal.Union _ _ v) = WithSchema . fromSchema' @_ @_ @sch @f <$> A.fromAvro v - fromAvro v = ASch.badValue v "top-level" -instance ( ToSchema Identity sch sty t, HasAvroSchemas sch sch + fromAvro v = WithSchema . fromSchema' @_ @_ @sch @f <$> A.fromAvro v +instance ( ToSchema Identity sch sty t , A.ToAvro (Term Identity sch (sch :/: sty)) ) => A.ToAvro (WithSchema Identity sch sty t) where - toAvro (WithSchema v) = AVal.Union (schemas (Proxy @sch) (Proxy @sch)) - (unTagged $ A.schema @(Term Identity sch (sch :/: sty))) - (A.toAvro (toSchema' @_ @_ @sch @Identity v)) - -class HasAvroSchemas (r :: Schema tn fn) (sch :: Schema tn fn) where - schemas :: Proxy r -> Proxy sch -> V.Vector ASch.Type -instance HasAvroSchemas r '[] where - schemas _ _ = V.empty -instance forall r d ds. - (A.HasAvroSchema (Term Identity r d), HasAvroSchemas r ds) - => HasAvroSchemas r (d ': ds) where - schemas pr _ = V.cons thisSchema (schemas pr (Proxy @ds)) - where thisSchema = unTagged $ A.schema @(Term Identity r d) + toAvro (WithSchema v) = A.toAvro (toSchema' @_ @_ @sch @Identity v) -- HasAvroSchema instances +class HasAvroSchema' x where + schema' :: [ASch.TypeName] -> Tagged x ASch.Type + +instance HasAvroSchema' (Term f sch t) + => A.HasAvroSchema (Term f sch t) where + schema = schema' [] +instance HasAvroSchema' (FieldValue f sch t) + => A.HasAvroSchema (FieldValue f sch t) where + schema = schema' [] + instance (KnownName name, HasAvroSchemaFields sch args) - => A.HasAvroSchema (Term f sch ('DRecord name args)) where - schema = Tagged $ ASch.Record recordName [] Nothing Nothing fields + => HasAvroSchema' (Term f sch ('DRecord name args)) where + schema' visited + = if recordName `elem` visited + then Tagged $ ASch.NamedType recordName + else Tagged $ ASch.Record recordName [] Nothing Nothing fields where recordName = nameTypeName (Proxy @name) - fields = schemaF (Proxy @sch) (Proxy @args) + fields = schemaF (Proxy @sch) (Proxy @args) visited instance (KnownName name, HasAvroSchemaEnum choices) - => A.HasAvroSchema (Term f sch ('DEnum name choices)) where - schema = Tagged $ ASch.mkEnum enumName [] Nothing choicesNames + => HasAvroSchema' (Term f sch ('DEnum name choices)) where + 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) -instance A.HasAvroSchema (FieldValue f sch t) - => A.HasAvroSchema (Term f sch ('DSimple t)) where - schema = coerce $ A.schema @(FieldValue f sch t) +instance HasAvroSchema' (FieldValue f sch t) + => HasAvroSchema' (Term f sch ('DSimple t)) where + schema' visited = coerce $ schema' @(FieldValue f sch t) visited -instance A.HasAvroSchema (FieldValue f sch 'TNull) where - schema = Tagged ASch.Null +instance HasAvroSchema' (FieldValue f sch 'TNull) where + schema' _ = Tagged ASch.Null instance A.HasAvroSchema t - => A.HasAvroSchema (FieldValue f sch ('TPrimitive t)) where - schema = coerce $ A.schema @t -instance KnownName t - => A.HasAvroSchema (FieldValue f sch ('TSchematic t)) where - -- schema = coerce $ A.schema @(Term sch (sch :/: t)) - schema = Tagged $ ASch.NamedType (nameTypeName (Proxy @t)) + => HasAvroSchema' (FieldValue f sch ('TPrimitive t)) where + schema' _ = coerce $ A.schema @t +instance (HasAvroSchema' (Term f sch (sch :/: t))) + => HasAvroSchema' (FieldValue f sch ('TSchematic t)) where + schema' visited = coerce $ schema' @(Term f sch (sch :/: t)) visited instance forall sch f choices. HasAvroSchemaUnion (FieldValue f sch) choices - => A.HasAvroSchema (FieldValue f sch ('TUnion choices)) where - schema = Tagged $ ASch.mkUnion $ schemaU (Proxy @(FieldValue f sch)) (Proxy @choices) -instance A.HasAvroSchema (FieldValue f sch t) - => A.HasAvroSchema (FieldValue f sch ('TOption t)) where - schema = coerce $ A.schema @(Maybe (FieldValue f sch t)) -instance A.HasAvroSchema (FieldValue f sch t) - => A.HasAvroSchema (FieldValue f sch ('TList t)) where - schema = coerce $ A.schema @[FieldValue f sch t] + => HasAvroSchema' (FieldValue f sch ('TUnion choices)) where + schema' visited + = Tagged $ ASch.mkUnion $ schemaU (Proxy @(FieldValue f sch)) (Proxy @choices) visited +instance HasAvroSchema' (FieldValue f sch t) + => HasAvroSchema' (FieldValue f sch ('TOption t)) where + schema' visited + = Tagged $ ASch.mkUnion $ ASch.Null :| [iSchema] + where iSchema = unTagged $ schema' @(FieldValue f sch t) visited +instance HasAvroSchema' (FieldValue f sch t) + => HasAvroSchema' (FieldValue f sch ('TList t)) where + schema' visited + = Tagged $ ASch.Array iSchema + where iSchema = unTagged $ schema' @(FieldValue f sch t) visited -- These are the only two versions of Map supported by the library -instance A.HasAvroSchema (FieldValue f sch v) - => A.HasAvroSchema (FieldValue f sch ('TMap ('TPrimitive T.Text) v)) where - schema = coerce $ A.schema @(M.Map T.Text (FieldValue f sch v)) -instance A.HasAvroSchema (FieldValue f sch v) - => A.HasAvroSchema (FieldValue f sch ('TMap ('TPrimitive String) v)) where - schema = coerce $ A.schema @(M.Map String (FieldValue f sch v)) +instance HasAvroSchema' (FieldValue f sch v) + => HasAvroSchema' (FieldValue f sch ('TMap ('TPrimitive T.Text) v)) where + schema' visited + = Tagged $ ASch.Map iSchema + where iSchema = unTagged $ schema' @(FieldValue f sch v) visited +instance HasAvroSchema' (FieldValue f sch v) + => HasAvroSchema' (FieldValue f sch ('TMap ('TPrimitive String) v)) where + schema' visited + = Tagged $ ASch.Map iSchema + where iSchema = unTagged $ schema' @(FieldValue f sch v) visited class HasAvroSchemaUnion (f :: k -> *) (xs :: [k]) where - schemaU :: Proxy f -> Proxy xs -> NonEmpty ASch.Type -instance A.HasAvroSchema (f v) => HasAvroSchemaUnion f '[v] where - schemaU _ _ = vSchema :| [] - where vSchema = unTagged (A.schema @(f v)) -instance (A.HasAvroSchema (f x), HasAvroSchemaUnion f (y ': zs)) + schemaU :: Proxy f -> Proxy xs -> [ASch.TypeName] -> NonEmpty ASch.Type +instance HasAvroSchema' (f v) => HasAvroSchemaUnion f '[v] where + schemaU _ _ visited = vSchema :| [] + where vSchema = unTagged (schema' @(f v) visited) +instance (HasAvroSchema' (f x), HasAvroSchemaUnion f (y ': zs)) => HasAvroSchemaUnion f (x ': y ': zs) where - schemaU p _ = xSchema :| NonEmptyList.toList yzsSchema - where xSchema = unTagged (A.schema @(f x)) - yzsSchema = schemaU p (Proxy @(y ': zs)) + schemaU p _ visited = xSchema :| NonEmptyList.toList yzsSchema + where xSchema = unTagged (schema' @(f x) visited) + yzsSchema = schemaU p (Proxy @(y ': zs)) visited class HasAvroSchemaFields sch (fs :: [FieldDef tn fn]) where - schemaF :: Proxy sch -> Proxy fs -> [ASch.Field] + schemaF :: Proxy sch -> Proxy fs -> [ASch.TypeName] -> [ASch.Field] instance HasAvroSchemaFields sch '[] where - schemaF _ _ = [] -instance (KnownName name, A.HasAvroSchema (FieldValue Identity sch t), HasAvroSchemaFields sch fs) + schemaF _ _ _ = [] +instance (KnownName name, HasAvroSchema' (FieldValue Identity sch t), HasAvroSchemaFields sch fs) => HasAvroSchemaFields sch ('FieldDef name t ': fs) where - schemaF psch _ = schemaThis : schemaF psch (Proxy @fs) + schemaF psch _ visited = schemaThis : schemaF psch (Proxy @fs) visited where fieldName = nameText (Proxy @name) - schemaT = unTagged $ A.schema @(FieldValue Identity sch t) + schemaT = unTagged $ schema' @(FieldValue Identity sch t) visited schemaThis = ASch.Field fieldName [] Nothing Nothing schemaT Nothing class HasAvroSchemaEnum (fs :: [ChoiceDef fn]) where @@ -183,7 +192,7 @@ => A.FromAvro (Term f sch ('DEnum name choices)) where fromAvro v@(AVal.Enum _ n _) = TEnum <$> fromAvroEnum v n fromAvro v = A.badValue v "enum" -instance A.FromAvro (FieldValue f sch t) +instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t)) => A.FromAvro (Term f sch ('DSimple t)) where fromAvro v = TSimple <$> A.fromAvro v @@ -192,24 +201,25 @@ fromAvro v = A.badValue v "null" instance A.FromAvro t => A.FromAvro (FieldValue f sch ('TPrimitive t)) where fromAvro v = FPrimitive <$> A.fromAvro v -instance (KnownName t, A.FromAvro (Term f sch (sch :/: t))) +instance ( KnownName t, HasAvroSchema' (Term f sch (sch :/: t)) + , A.FromAvro (Term f sch (sch :/: t)) ) => A.FromAvro (FieldValue f sch ('TSchematic t)) where fromAvro v = FSchematic <$> A.fromAvro v instance (HasAvroSchemaUnion (FieldValue f sch) choices, FromAvroUnion f sch choices) => A.FromAvro (FieldValue f sch ('TUnion choices)) where fromAvro (AVal.Union _ branch v) = FUnion <$> fromAvroU branch v fromAvro v = A.badValue v "union" -instance A.FromAvro (FieldValue f sch t) +instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t)) => A.FromAvro (FieldValue f sch ('TOption t)) where fromAvro v = FOption <$> A.fromAvro v -instance A.FromAvro (FieldValue f sch t) +instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t)) => A.FromAvro (FieldValue f sch ('TList t)) where fromAvro v = FList <$> A.fromAvro v -- These are the only two versions of Map supported by the library -instance A.FromAvro (FieldValue f sch v) +instance (HasAvroSchema' (FieldValue f sch v), A.FromAvro (FieldValue f sch v)) => A.FromAvro (FieldValue f sch ('TMap ('TPrimitive T.Text) v)) where fromAvro v = FMap . M.mapKeys FPrimitive <$> A.fromAvro v -instance A.FromAvro (FieldValue f sch v) +instance (HasAvroSchema' (FieldValue f sch v), A.FromAvro (FieldValue f sch v)) => A.FromAvro (FieldValue f sch ('TMap ('TPrimitive String) v)) where fromAvro v = FMap . M.mapKeys (FPrimitive . T.unpack) <$> A.fromAvro v @@ -255,7 +265,7 @@ toAvro (TEnum n) = AVal.Enum wholeSchema choice text where wholeSchema = unTagged (A.schema @(Term Identity sch ('DEnum name choices))) (choice, text) = toAvroE n -instance A.ToAvro (FieldValue Identity sch t) +instance (HasAvroSchema' (FieldValue Identity sch t), A.ToAvro (FieldValue Identity sch t)) => A.ToAvro (Term Identity sch ('DSimple t)) where toAvro (TSimple v) = A.toAvro v @@ -263,27 +273,28 @@ toAvro FNull = AVal.Null instance A.ToAvro t => A.ToAvro (FieldValue Identity sch ('TPrimitive t)) where toAvro (FPrimitive v) = A.toAvro v -instance (KnownName t, A.ToAvro (Term Identity sch (sch :/: t))) +instance ( KnownName t, HasAvroSchema' (Term Identity sch (sch :/: t)) + , A.ToAvro (Term Identity sch (sch :/: t)) ) => A.ToAvro (FieldValue Identity sch ('TSchematic t)) where toAvro (FSchematic v) = A.toAvro v instance forall sch choices. (HasAvroSchemaUnion (FieldValue Identity sch) choices, ToAvroUnion sch choices) => A.ToAvro (FieldValue Identity sch ('TUnion choices)) where toAvro (FUnion v) = AVal.Union wholeSchema' chosenTy chosenVal - where wholeSchema = schemaU (Proxy @(FieldValue Identity sch)) (Proxy @choices) + where wholeSchema = schemaU (Proxy @(FieldValue Identity sch)) (Proxy @choices) [] wholeSchema' = V.fromList (NonEmptyList.toList wholeSchema) (chosenTy, chosenVal) = toAvroU v -instance A.ToAvro (FieldValue Identity sch t) +instance (HasAvroSchema' (FieldValue Identity sch t), A.ToAvro (FieldValue Identity sch t)) => A.ToAvro (FieldValue Identity sch ('TOption t)) where toAvro (FOption v) = A.toAvro v -instance A.ToAvro (FieldValue Identity sch t) +instance (HasAvroSchema' (FieldValue Identity sch t), A.ToAvro (FieldValue Identity sch t)) => A.ToAvro (FieldValue Identity sch ('TList t)) where toAvro (FList v) = AVal.Array $ V.fromList $ A.toAvro <$> v -- These are the only two versions of Map supported by the library -instance A.ToAvro (FieldValue Identity sch v) +instance (HasAvroSchema' (FieldValue Identity sch v), A.ToAvro (FieldValue Identity sch v)) => A.ToAvro (FieldValue Identity sch ('TMap ('TPrimitive T.Text) v)) where toAvro (FMap v) = A.toAvro $ M.mapKeys (\(FPrimitive k) -> k) v -instance A.ToAvro (FieldValue Identity sch v) +instance (HasAvroSchema' (FieldValue Identity sch v), A.ToAvro (FieldValue Identity sch v)) => A.ToAvro (FieldValue Identity sch ('TMap ('TPrimitive String) v)) where toAvro (FMap v) = A.toAvro $ M.mapKeys (\(FPrimitive k) -> k) v 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,8 +1,9 @@ -{-# language DataKinds #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language TemplateHaskell #-} -{-# language ViewPatterns #-} +{-# language DataKinds #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language TemplateHaskell #-} +{-# language ViewPatterns #-} {-| Description : Quasi-quoters for Avro IDL format @@ -16,23 +17,34 @@ is supported, not the Java-like one. -} module Mu.Quasi.Avro ( + -- * Service generation from @.avdl@ files + avdl -- * Quasi-quoters for @.avsc@ files - avro - , avroFile +, avro +, avroFile -- * Only for internal use - , schemaFromAvroType - ) where +, schemaFromAvroType +) where +import Control.Monad.IO.Class import Data.Aeson (decode) import qualified Data.Avro.Schema as A +import Data.Avro.Types.Decimal as D import qualified Data.ByteString as B import Data.ByteString.Lazy.Char8 (pack) import Data.Int +import qualified Data.Set as S import qualified Data.Text as T -import Data.Vector (fromList, toList) +import Data.Time +import Data.Time.Millis +import Data.UUID +import qualified Data.Vector as V +import Language.Avro.Parser +import qualified Language.Avro.Types as A import Language.Haskell.TH import Language.Haskell.TH.Quote +import Mu.Rpc import Mu.Schema.Definition -- | Imports an avro definition written in-line as a 'Schema'. @@ -43,22 +55,52 @@ (const $ fail "cannot use as pattern") schemaFromAvroString (const $ fail "cannot use as declaration") + where + schemaFromAvroString :: String -> Q Type + schemaFromAvroString s = + case decode (pack s) of + Nothing -> fail "could not parse avro spec!" + Just (A.Union us) -> schemaFromAvro (V.toList us) + Just t -> schemaFromAvro [t] -- | Imports an avro definition from a file as a 'Schema'. avroFile :: QuasiQuoter avroFile = quoteFile avro -schemaFromAvroString :: String -> Q Type -schemaFromAvroString s = - case decode (pack s) of - Nothing -> fail "could not parse avro spec!" - Just (A.Union us) -> schemaFromAvro (toList us) - Just t -> schemaFromAvro [t] +-- | Reads a @.proto@ file and generates: +-- * A 'Mu.Schema.Definition.Schema' with all the message +-- types, using the name given as first argument. +-- * A 'Service' declaration for each service in the file, +-- where the name is obtained by applying the function +-- given as second argument to the name in the file. +avdl :: String -> String -> FilePath -> FilePath -> Q [Dec] +avdl schemaName serviceName baseDir initialFile + = do r <- liftIO $ readWithImports baseDir initialFile + case r of + Left e + -> fail ("could not parse protocol buffers spec: " ++ show e) + Right p + -> avdlToDecls schemaName serviceName p + +avdlToDecls :: String -> String -> A.Protocol -> Q [Dec] +avdlToDecls schemaName serviceName protocol + = do let schemaName' = mkName schemaName + serviceName' = mkName serviceName + schemaDec <- tySynD schemaName' [] (schemaFromAvro $ S.toList (A.types protocol)) + serviceDec <- tySynD serviceName' [] + [t| 'Service $(textToStrLit (A.pname protocol)) $(pkgType (A.ns protocol)) + $(typesToList <$> mapM (avroMethodToType schemaName') (S.toList $ A.messages protocol)) |] + return [schemaDec, serviceDec] where - schemaFromAvro = - (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls + pkgType Nothing = [t| '[] |] + pkgType (Just (A.Namespace p)) + = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |] -schemaDecFromAvroType :: A.Type -> Q Type +schemaFromAvro :: [A.Schema] -> Q Type +schemaFromAvro = + (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls + +schemaDecFromAvroType :: A.Schema -> Q Type schemaDecFromAvroType (A.Record name _ _ _ fields) = [t|'DRecord $(textToStrLit $ A.baseName name) $(typesToList <$> mapM avroFieldToType fields)|] @@ -69,24 +111,30 @@ $(schemaFromAvroType $ A.fldType field)|] schemaDecFromAvroType (A.Enum name _ _ symbols) = [t|'DEnum $(textToStrLit $ A.baseName name) - $(typesToList <$> mapM avChoiceToType (toList symbols))|] + $(typesToList <$> mapM avChoiceToType (V.toList symbols))|] where avChoiceToType :: T.Text -> Q Type avChoiceToType c = [t|'ChoiceDef $(textToStrLit c)|] schemaDecFromAvroType t = [t|'DSimple $(schemaFromAvroType t)|] -- | Turns a schema from Avro into a Template Haskell 'Type'. -schemaFromAvroType :: A.Type -> Q Type +schemaFromAvroType :: A.Schema -> Q Type schemaFromAvroType = \case A.Null -> [t|'TPrimitive 'TNull|] A.Boolean -> [t|'TPrimitive Bool|] - A.Int -> [t|'TPrimitive Int32|] - A.Long -> [t|'TPrimitive Int64|] + A.Int (Just A.Date) -> [t|'TPrimitive Day|] + A.Int (Just A.TimeMillis) -> [t|'TPrimitive DiffTimeMs|] + A.Int _ -> [t|'TPrimitive Int32|] + A.Long (Just (A.DecimalL (A.Decimal p s))) + -> [t|'TPrimitive (D.Decimal $(litT $ numTyLit p) $(litT $ numTyLit s)) |] + A.Long (Just A.TimeMicros) -> [t|'TPrimitive DiffTime|] + A.Long _ -> [t|'TPrimitive Int64|] A.Float -> [t|'TPrimitive Float|] A.Double -> [t|'TPrimitive Double|] - A.Bytes -> [t|'TPrimitive B.ByteString|] - A.String -> [t|'TPrimitive T.Text|] + A.Bytes _ -> [t|'TPrimitive B.ByteString|] + A.String (Just A.UUID) -> [t|'TPrimitive UUID|] + A.String _ -> [t|'TPrimitive T.Text|] A.Array item -> [t|'TList $(schemaFromAvroType item)|] A.Map values -> [t|'TMap T.Text $(schemaFromAvroType values)|] A.NamedType typeName -> @@ -94,36 +142,56 @@ A.Enum {} -> fail "should never happen, please, file an issue" A.Record {} -> fail "should never happen, please, file an issue" A.Union options -> - case toList options of + case V.toList options of [A.Null, x] -> toOption x [x, A.Null] -> toOption x _ -> - [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (toList options))|] + [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (V.toList options))|] where toOption x = [t|'TOption $(schemaFromAvroType x)|] A.Fixed {} -> fail "fixed integers are not currently supported" -flattenAvroDecls :: [A.Type] -> [A.Type] +flattenAvroDecls :: [A.Schema] -> [A.Schema] flattenAvroDecls = concatMap (uncurry (:) . flattenDecl) where - flattenDecl :: A.Type -> (A.Type, [A.Type]) + flattenDecl :: A.Schema -> (A.Schema, [A.Schema]) flattenDecl (A.Record name a d o fields) = let (flds, tts) = unzip (flattenAvroField <$> fields) in (A.Record name a d o flds, concat tts) flattenDecl (A.Union _) = error "should never happen, please, file an issue" flattenDecl t = (t, []) - flattenAvroType :: A.Type -> (A.Type, [A.Type]) + flattenAvroType :: A.Schema -> (A.Schema, [A.Schema]) flattenAvroType (A.Record name a d o fields) = let (flds, tts) = unzip (flattenAvroField <$> fields) in (A.NamedType name, A.Record name a d o flds : concat tts) - flattenAvroType (A.Union (toList -> ts)) = + flattenAvroType (A.Union (V.toList -> ts)) = let (us, tts) = unzip (map flattenAvroType ts) - in (A.Union $ fromList us, concat tts) + in (A.Union $ V.fromList us, concat tts) flattenAvroType e@A.Enum {A.name} = (A.NamedType name, [e]) flattenAvroType t = (t, []) - flattenAvroField :: A.Field -> (A.Field, [A.Type]) + flattenAvroField :: A.Field -> (A.Field, [A.Schema]) flattenAvroField f = let (t, decs) = flattenAvroType (A.fldType f) in (f {A.fldType = t}, decs) + +avroMethodToType :: Name -> A.Method -> Q Type +avroMethodToType schemaName 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 ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |] + argToType (A.Argument _ _) + = fail "only named types may be used as arguments" + + retToType :: A.Schema -> Q Type + retToType A.Null + = [t| 'RetNothing |] + retToType (A.NamedType a) + = [t| 'RetSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |] + retToType _ + = fail "only named types may be used as results" typesToList :: [Type] -> Type typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT diff --git a/test/Avro.hs b/test/Avro.hs --- a/test/Avro.hs +++ b/test/Avro.hs @@ -19,7 +19,7 @@ exampleAddress = Address "1111BB" "Spain" examplePerson1, examplePerson2 :: Person -examplePerson1 = Person "Haskellio" "Gómez" (Just 30) (Just Male) exampleAddress +examplePerson1 = Person "Haskellio" "Gomez" (Just 30) (Just Male) exampleAddress examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress deriving via (WithSchema Identity ExampleSchema "person" Person) instance HasAvroSchema Person