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.2.0.0 +version: 0.3.0.0 synopsis: Avro serialization support for Mu microservices description: You can use @mu-avro@ to read AVRO Schema Declarations for mu-haskell @@ -29,14 +29,14 @@ build-depends: aeson - , avro >=0.4.7 - , base >=4.12 && <5 + , avro >=0.5.1 + , base >=4.12 && <5 , bytestring , containers , deepseq - , language-avro >=0.1.2 - , mu-rpc >=0.2.0 - , mu-schema >=0.2.0 + , language-avro >=0.1.3.1 + , mu-rpc >=0.3.0 + , mu-schema >=0.3.0 , sop-core , tagged , template-haskell >=2.12 @@ -53,11 +53,11 @@ executable test-avro main-is: Avro.hs build-depends: - avro >=0.4.7 + avro >=0.5 , base >=4.12 && <5 , bytestring - , mu-avro >=0.2.0 - , mu-schema >=0.2.0 + , mu-avro >=0.3.0 + , mu-schema >=0.3.0 hs-source-dirs: test default-language: Haskell2010 diff --git a/src/Data/Time/Millis.hs b/src/Data/Time/Millis.hs --- a/src/Data/Time/Millis.hs +++ b/src/Data/Time/Millis.hs @@ -1,41 +1,42 @@ {-# language GeneralizedNewtypeDeriving #-} -module Data.Time.Millis where +{-| +Description : Time differences in milliseconds +Avro defines a specific logical type for time +differences expessed in milliseconds. This module +provides a type which wraps the 'DiffTime' from +the @time@ library (which uses nanoseconds), +offering a millisecond-based interface. +-} +module Data.Time.Millis where -import Control.DeepSeq (NFData) -import Data.Avro.Encode -import Data.Avro.EncodeRaw -import Data.Avro.FromAvro +import Control.DeepSeq (NFData) +import Data.Avro.Encoding.FromAvro +import Data.Avro.Encoding.ToAvro import Data.Avro.HasAvroSchema -import Data.Avro.Schema as S -import Data.Avro.ToAvro -import Data.Avro.Types as T +import qualified Data.Avro.Schema.Schema as S +import Data.Int (Int32) 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) + schema = Tagged $ S.Int (Just S.TimeMillis) instance ToAvro DiffTimeMs where - toAvro = T.Int . fromIntegral . diffTimeToMillis + toAvro s = toAvro s . (fromIntegral :: Integer -> Int32) . diffTimeToMillis instance FromAvro DiffTimeMs where - fromAvro (T.Int v) = pure $ millisToDiffTime (toInteger v) - fromAvro v = badValue v "TimeMicros" + fromAvro (Int _ v) = pure $ millisToDiffTime (toInteger v) + fromAvro _ = Left "expecting time_ms" +-- | Obtain the underlying time in milliseconds from a 'DiffTimeMs'. diffTimeToMillis :: DiffTimeMs -> Integer diffTimeToMillis = (`div` 1000000000) . diffTimeToPicoseconds . unDiffTimeMs +-- | Build a 'DiffTimeMs' from an amount expressed in milliseconds. 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 @@ -8,6 +8,7 @@ {-# language RankNTypes #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} +{-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,18 +21,24 @@ -} module Mu.Adapter.Avro () where +import Control.Applicative ((<|>)) import Control.Arrow ((***)) import qualified Data.Avro as A -import qualified Data.Avro.Schema as ASch -import qualified Data.Avro.Types.Value as AVal +import qualified Data.Avro.Encoding.FromAvro as AVal +import qualified Data.Avro.Encoding.ToAvro as A +import qualified Data.Avro.Schema.ReadSchema as RSch +import qualified Data.Avro.Schema.Schema as ASch -- 'Tagged . unTagged' can be replaced by 'coerce' -- eliminating some run-time overhead +import Data.Avro.EitherN (putIndexedValue) +import Data.ByteString.Builder (Builder, word8) import Data.Coerce (coerce) -import Data.Functor.Identity 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 +import Data.Maybe (fromJust) import Data.Tagged import qualified Data.Text as T import qualified Data.Vector as V @@ -40,26 +47,29 @@ import Mu.Schema import qualified Mu.Schema.Interpretation.Schemaless as SLess -instance SLess.ToSchemalessTerm (AVal.Value t) Identity where - toSchemalessTerm (AVal.Record _ r) - = SLess.TRecord $ map (\(k,v) -> SLess.Field k (Identity $ SLess.toSchemalessValue v)) - $ HM.toList r +instance SLess.ToSchemalessTerm AVal.Value where + 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) + _ -> error ("this should never happen:\n" ++ show s) toSchemalessTerm (AVal.Enum _ i _) = SLess.TEnum i toSchemalessTerm (AVal.Union _ _ v) = SLess.toSchemalessTerm v toSchemalessTerm v = SLess.TSimple (SLess.toSchemalessValue v) -instance SLess.ToSchemalessValue (AVal.Value t) Identity where - toSchemalessValue AVal.Null = SLess.FNull - toSchemalessValue (AVal.Boolean b) = SLess.FPrimitive b - toSchemalessValue (AVal.Int b) = SLess.FPrimitive b - toSchemalessValue (AVal.Long b) = SLess.FPrimitive b - toSchemalessValue (AVal.Float b) = SLess.FPrimitive b - toSchemalessValue (AVal.Double b) = SLess.FPrimitive b - toSchemalessValue (AVal.String b) = SLess.FPrimitive b - toSchemalessValue (AVal.Fixed _ b) = SLess.FPrimitive b - toSchemalessValue (AVal.Bytes b) = SLess.FPrimitive b +instance SLess.ToSchemalessValue AVal.Value where + toSchemalessValue AVal.Null = SLess.FNull + toSchemalessValue (AVal.Boolean b) = SLess.FPrimitive b + toSchemalessValue (AVal.Int _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Long _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Float _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Double _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.String _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Fixed _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Bytes _ b) = SLess.FPrimitive b toSchemalessValue (AVal.Array v) = SLess.FList $ map SLess.toSchemalessValue $ V.toList v toSchemalessValue (AVal.Map hm) @@ -73,87 +83,129 @@ toSchemalessValue e@AVal.Enum {} = SLess.FSchematic (SLess.toSchemalessTerm e) -instance A.HasAvroSchema (Term f sch (sch :/: sty)) - => A.HasAvroSchema (WithSchema f sch sty t) where - 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 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) = A.toAvro (toSchema' @_ @_ @sch @Identity v) +instance (HasAvroSchemas sch sch) + => A.HasAvroSchema (WithSchema sch sty t) where + schema = Tagged $ ASch.Union $ schemas (Proxy @sch) (Proxy @sch) ts + where ts = typeNames (Proxy @sch) (Proxy @sch) +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 +instance ( ToSchema sch sty t + , A.ToAvro (Term sch (sch :/: sty)) + , KnownNat (IxOf 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 + -- HasAvroSchema instances class HasAvroSchema' x where - schema' :: [ASch.TypeName] -> Tagged x ASch.Type + typeName' :: Proxy x -> [ASch.TypeName] + schema' :: [ASch.TypeName] -> Tagged x ASch.Schema -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 +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' [] instance (KnownName name, HasAvroSchemaFields sch args) - => HasAvroSchema' (Term f sch ('DRecord name args)) where + => 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 Nothing fields + else Tagged $ ASch.Record recordName [] Nothing fields where recordName = nameTypeName (Proxy @name) fields = schemaF (Proxy @sch) (Proxy @args) visited instance (KnownName name, HasAvroSchemaEnum choices) - => HasAvroSchema' (Term f sch ('DEnum name choices)) where + => 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) -instance HasAvroSchema' (FieldValue f sch t) - => HasAvroSchema' (Term f sch ('DSimple t)) where - schema' visited = coerce $ schema' @(FieldValue f sch t) visited +instance HasAvroSchema' (FieldValue sch t) + => HasAvroSchema' (Term sch ('DSimple t)) where + typeName' _ = [] + schema' visited = coerce $ schema' @(FieldValue sch t) visited -instance HasAvroSchema' (FieldValue f sch 'TNull) where +instance HasAvroSchema' (FieldValue sch 'TNull) where + typeName' _ = [] schema' _ = Tagged ASch.Null instance A.HasAvroSchema t - => HasAvroSchema' (FieldValue f sch ('TPrimitive t)) where + => HasAvroSchema' (FieldValue sch ('TPrimitive t)) where + typeName' _ = [] 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 - => HasAvroSchema' (FieldValue f sch ('TUnion choices)) where +instance (HasAvroSchema' (Term sch (sch :/: t))) + => HasAvroSchema' (FieldValue sch ('TSchematic t)) where + typeName' _ = [] + schema' visited = coerce $ schema' @(Term sch (sch :/: t)) visited +instance forall sch choices. + HasAvroSchemaUnion (FieldValue sch) choices + => HasAvroSchema' (FieldValue sch ('TUnion choices)) where + typeName' _ = [] 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 + = Tagged $ ASch.mkUnion $ schemaU (Proxy @(FieldValue sch)) (Proxy @choices) visited +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 f sch t) visited -instance HasAvroSchema' (FieldValue f sch t) - => HasAvroSchema' (FieldValue f sch ('TList t)) where + where iSchema = unTagged $ schema' @(FieldValue sch t) visited +instance HasAvroSchema' (FieldValue sch t) + => HasAvroSchema' (FieldValue sch ('TList t)) where + typeName' _ = [] schema' visited = Tagged $ ASch.Array iSchema - where iSchema = unTagged $ schema' @(FieldValue f sch t) visited + where iSchema = unTagged $ schema' @(FieldValue sch t) visited -- These are the only two versions of Map supported by the library -instance HasAvroSchema' (FieldValue f sch v) - => HasAvroSchema' (FieldValue f sch ('TMap ('TPrimitive T.Text) v)) where +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 f sch v) visited -instance HasAvroSchema' (FieldValue f sch v) - => HasAvroSchema' (FieldValue f sch ('TMap ('TPrimitive String) v)) where + where iSchema = unTagged $ schema' @(FieldValue sch v) visited +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 f sch v) visited + where iSchema = unTagged $ schema' @(FieldValue sch v) visited class HasAvroSchemaUnion (f :: k -> *) (xs :: [k]) where - schemaU :: Proxy f -> Proxy xs -> [ASch.TypeName] -> NonEmpty ASch.Type + schemaU :: Proxy f -> Proxy xs -> [ASch.TypeName] -> NonEmpty ASch.Schema instance HasAvroSchema' (f v) => HasAvroSchemaUnion f '[v] where schemaU _ _ visited = vSchema :| [] where vSchema = unTagged (schema' @(f v) visited) @@ -167,11 +219,11 @@ schemaF :: Proxy sch -> Proxy fs -> [ASch.TypeName] -> [ASch.Field] instance HasAvroSchemaFields sch '[] where schemaF _ _ _ = [] -instance (KnownName name, HasAvroSchema' (FieldValue Identity sch t), HasAvroSchemaFields sch fs) +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 Identity sch t) visited + schemaT = unTagged $ schema' @(FieldValue sch t) visited schemaThis = ASch.Field fieldName [] Nothing Nothing schemaT Nothing class HasAvroSchemaEnum (fs :: [ChoiceDef fn]) where @@ -184,148 +236,153 @@ -- FromAvro instances -instance (KnownName name, HasAvroSchemaFields sch args, FromAvroFields f sch args) - => A.FromAvro (Term f sch ('DRecord name args)) where - fromAvro (AVal.Record _ fields) = TRecord <$> fromAvroF fields - fromAvro v = A.badValue v "record" -instance (KnownName name, HasAvroSchemaEnum choices, FromAvroEnum choices) - => 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 (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 +instance (KnownName name, FromAvroFields sch args) + => A.FromAvro (Term sch ('DRecord name args)) where + fromAvro (AVal.Record RSch.Record { RSch.fields = fs } fields) + = TRecord <$> fromAvroF r + where + r = HM.fromList $ zip (map RSch.fldName fs) (V.toList fields) + fromAvro _ = Left "expecting record" +instance (KnownName name, FromAvroEnum choices) + => A.FromAvro (Term sch ('DEnum name choices)) where + fromAvro (AVal.Enum _ _ v) = TEnum <$> fromAvroEnum v + fromAvro _ = Left "expecting enum" +instance (A.FromAvro (FieldValue sch t)) + => A.FromAvro (Term sch ('DSimple t)) where + fromAvro v = TSimple <$> AVal.fromAvro v -instance A.FromAvro (FieldValue f sch 'TNull) where - fromAvro AVal.Null = return FNull - 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, 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 (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 (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 +instance A.FromAvro (FieldValue sch 'TNull) where + fromAvro AVal.Null = pure FNull + fromAvro _ = Left "expecting null" +instance A.FromAvro t => A.FromAvro (FieldValue sch ('TPrimitive t)) where + fromAvro v = FPrimitive <$> AVal.fromAvro v +instance ( KnownName t, A.FromAvro (Term sch (sch :/: t)) ) + => A.FromAvro (FieldValue sch ('TSchematic t)) where + fromAvro v = FSchematic <$> AVal.fromAvro v +instance (FromAvroUnion sch choices) + => A.FromAvro (FieldValue sch ('TUnion choices)) where + fromAvro (AVal.Union _ i v) = FUnion <$> fromAvroU i v + fromAvro _ = Left "expecting union" +instance (A.FromAvro (FieldValue sch t)) + => A.FromAvro (FieldValue sch ('TOption t)) where + fromAvro v = FOption <$> AVal.fromAvro v +instance (A.FromAvro (FieldValue sch t)) + => A.FromAvro (FieldValue sch ('TList t)) where + fromAvro v = FList <$> AVal.fromAvro v -- These are the only two versions of Map supported by the library -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 (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 +instance (A.FromAvro (FieldValue sch v)) + => A.FromAvro (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where + fromAvro v = FMap . M.mapKeys FPrimitive <$> AVal.fromAvro v +instance (A.FromAvro (FieldValue sch v)) + => A.FromAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where + fromAvro v = FMap . M.mapKeys (FPrimitive . T.unpack) <$> AVal.fromAvro v class FromAvroEnum (vs :: [ChoiceDef fn]) where - fromAvroEnum :: AVal.Value ASch.Type -> Int -> A.Result (NS Proxy vs) + fromAvroEnum :: T.Text -> Either String (NS Proxy vs) instance FromAvroEnum '[] where - fromAvroEnum v _ = A.badValue v "element not found" -instance FromAvroEnum vs => FromAvroEnum (v ': vs) where - fromAvroEnum _ 0 = return (Z Proxy) - fromAvroEnum v n = S <$> fromAvroEnum v (n-1) + fromAvroEnum _ = Left "enum choice not found" +instance (KnownName name, FromAvroEnum vs) + => FromAvroEnum ('ChoiceDef name ': vs) where + fromAvroEnum s + | s == fieldName = pure $ Z Proxy + | otherwise = S <$> fromAvroEnum s + where fieldName = nameText (Proxy @name) -class FromAvroUnion f sch choices where - fromAvroU :: ASch.Type -> AVal.Value ASch.Type -> ASch.Result (NS (FieldValue f sch) choices) -instance FromAvroUnion f sch '[] where - fromAvroU _ v = A.badValue v "union choice not found" -instance (A.FromAvro (FieldValue f sch u), FromAvroUnion f sch us) - => FromAvroUnion f sch (u ': us) where - fromAvroU branch v - | ASch.matches branch (unTagged (A.schema @(FieldValue f sch u))) - = Z <$> A.fromAvro v - | otherwise - = S <$> fromAvroU branch v +class FromAvroUnion sch choices where + fromAvroU :: Int -> AVal.Value -> Either String (NS (FieldValue sch) choices) +instance FromAvroUnion sch '[] where + fromAvroU _ _ = Left "union choice not found" +instance (A.FromAvro (FieldValue sch u), FromAvroUnion sch us) + => FromAvroUnion sch (u ': us) where + fromAvroU 0 v = Z <$> AVal.fromAvro v + fromAvroU n v = S <$> fromAvroU (n-1) v -class FromAvroFields f sch (fs :: [FieldDef Symbol Symbol]) where - fromAvroF :: HM.HashMap T.Text (AVal.Value ASch.Type) -> A.Result (NP (Field f sch) fs) -instance FromAvroFields f sch '[] where - fromAvroF _ = return Nil -instance (Applicative f, KnownName name, A.FromAvro (FieldValue f sch t), FromAvroFields f sch fs) - => FromAvroFields f sch ('FieldDef name t ': fs) where +class FromAvroFields sch (fs :: [FieldDef Symbol Symbol]) where + fromAvroF :: HM.HashMap T.Text AVal.Value + -> Either String (NP (Field sch) fs) +instance FromAvroFields sch '[] where + fromAvroF _ = pure Nil +instance (KnownName name, A.FromAvro (FieldValue sch t), FromAvroFields sch fs) + => FromAvroFields sch ('FieldDef name t ': fs) where fromAvroF v = case HM.lookup fieldName v of - Nothing -> A.badValue v "field not found" - Just f -> (:*) <$> (Field . pure <$> A.fromAvro f) <*> fromAvroF v + Nothing -> Left "field not found" + Just f -> (:*) <$> (Field <$> AVal.fromAvro f) <*> fromAvroF v where fieldName = nameText (Proxy @name) -- ToAvro instances -instance (KnownName name, HasAvroSchemaFields sch args, ToAvroFields sch args) - => A.ToAvro (Term Identity sch ('DRecord name args)) where - toAvro (TRecord fields) = AVal.Record wholeSchema (toAvroF fields) - where wholeSchema = unTagged (A.schema @(Term Identity sch ('DRecord name args))) -instance (KnownName name, HasAvroSchemaEnum choices, ToAvroEnum choices) - => A.ToAvro (Term Identity sch ('DEnum name choices)) where - toAvro (TEnum n) = AVal.Enum wholeSchema choice text - where wholeSchema = unTagged (A.schema @(Term Identity sch ('DEnum name choices))) - (choice, text) = toAvroE n -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 +instance (KnownName name, ToAvroFields sch args, HasAvroSchemaFields sch args) + => A.ToAvro (Term sch ('DRecord name args)) where + toAvro s@ASch.Record {} (TRecord fields) + = 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 +instance (KnownName name, ToAvroEnum choices, HasAvroSchemaEnum choices) + => A.ToAvro (Term sch ('DEnum name choices)) where + toAvro ASch.Enum { ASch.symbols = ss } (TEnum n) + = word8 $ fromIntegral $ toAvroE ss n + -- otherwise fall back to the one from schema + toAvro _ (TEnum n) + = word8 $ fromIntegral $ toAvroE (V.fromList $ schemaE (Proxy @choices)) n +instance (A.ToAvro (FieldValue sch t)) + => A.ToAvro (Term sch ('DSimple t)) where + toAvro s (TSimple v) = A.toAvro s v -instance A.ToAvro (FieldValue Identity sch 'TNull) where - 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, 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) [] - wholeSchema' = V.fromList (NonEmptyList.toList wholeSchema) - (chosenTy, chosenVal) = toAvroU v -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 (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 +instance A.ToAvro (FieldValue sch 'TNull) where + toAvro _ FNull = mempty +instance A.ToAvro t => A.ToAvro (FieldValue sch ('TPrimitive t)) where + toAvro s (FPrimitive v) = A.toAvro s v +instance ( KnownName t, A.ToAvro (Term sch (sch :/: t)) ) + => A.ToAvro (FieldValue sch ('TSchematic t)) where + toAvro s (FSchematic v) = A.toAvro s v +instance (ToAvroUnion sch choices) + => A.ToAvro (FieldValue sch ('TUnion choices)) where + toAvro (ASch.Union vs) (FUnion v) = toAvroU vs 0 v + toAvro s _ = error ("this should never happen:\n" ++ show s) +instance (A.ToAvro (FieldValue sch t)) + => A.ToAvro (FieldValue sch ('TOption t)) where + toAvro s (FOption v) = A.toAvro s v +instance (A.ToAvro (FieldValue sch t)) + => A.ToAvro (FieldValue sch ('TList t)) where + toAvro s (FList v) = A.toAvro s v -- These are the only two versions of Map supported by the library -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 (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 - -class ToAvroUnion sch choices where - toAvroU :: NS (FieldValue Identity sch) choices -> (ASch.Type, AVal.Value ASch.Type) -instance ToAvroUnion sch '[] where - toAvroU _ = error "ToAvro in an empty union" -instance forall sch u us. - (A.ToAvro (FieldValue Identity sch u), ToAvroUnion sch us) - => ToAvroUnion sch (u ': us) where - toAvroU (Z v) = (unTagged (A.schema @(FieldValue Identity sch u)), A.toAvro v) - toAvroU (S n) = toAvroU n +instance (A.ToAvro (FieldValue sch v)) + => A.ToAvro (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where + toAvro s (FMap v) = A.toAvro s $ M.mapKeys (\(FPrimitive k) -> k) v +instance (A.ToAvro (FieldValue sch v)) + => A.ToAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where + toAvro s (FMap v) = A.toAvro s $ M.mapKeys (\(FPrimitive k) -> T.pack k) v class ToAvroEnum choices where - toAvroE :: NS Proxy choices -> (Int, T.Text) + toAvroE :: V.Vector T.Text -> NS Proxy choices -> Int instance ToAvroEnum '[] where toAvroE = error "ToAvro in an empty enum" instance (KnownName u, ToAvroEnum us) => ToAvroEnum ('ChoiceDef u ': us) where - toAvroE (Z _) = (0, nameText (Proxy @u)) - toAvroE (S v) = let (n, t) = toAvroE v in (n + 1, t) + toAvroE s (Z _) = fromJust $ nameText (Proxy @u) `V.elemIndex` s + toAvroE s (S v) = toAvroE s v +class ToAvroUnion sch choices where + toAvroU :: V.Vector ASch.Schema + -> Int -> NS (FieldValue sch) choices -> Builder +instance ToAvroUnion sch '[] where + toAvroU = error "this should never happen" +instance (A.ToAvro (FieldValue sch u), ToAvroUnion sch us) + => ToAvroUnion sch (u ': us) where + toAvroU allSch n (Z v) + = putIndexedValue n allSch v + toAvroU allSch n (S v) + = toAvroU allSch (n+1) v + class ToAvroFields sch (fs :: [FieldDef Symbol Symbol]) where - toAvroF :: NP (Field Identity sch) fs -> HM.HashMap T.Text (AVal.Value ASch.Type) + toAvroF :: NP (Field sch) fs -> [(T.Text, A.Encoder)] instance ToAvroFields sch '[] where - toAvroF _ = HM.empty -instance (KnownName name, A.ToAvro (FieldValue Identity sch t), ToAvroFields sch fs) + toAvroF _ = [] +instance (KnownName name, A.ToAvro (FieldValue sch t), ToAvroFields sch fs) => ToAvroFields sch ('FieldDef name t ': fs) where - toAvroF (Field (Identity v) :* rest) = HM.insert fieldName fieldValue (toAvroF rest) + toAvroF (Field v :* rest) = (fieldName A..= v) : toAvroF rest where fieldName = nameText (Proxy @name) - fieldValue = A.toAvro v -- Conversion of symbols to other things nameText :: KnownName s => proxy s -> T.Text 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 @@ -28,8 +28,8 @@ import Control.Monad.IO.Class import Data.Aeson (decode) -import qualified Data.Avro.Schema as A -import Data.Avro.Types.Decimal as D +import Data.Avro.Schema.Decimal as D +import qualified Data.Avro.Schema.Schema as A import qualified Data.ByteString as B import Data.ByteString.Lazy.Char8 (pack) import Data.Int @@ -67,18 +67,17 @@ avroFile :: QuasiQuoter avroFile = quoteFile avro --- | Reads a @.proto@ file and generates: --- * A 'Mu.Schema.Definition.Schema' with all the message +-- | Reads a @.avdl@ file and generates: +-- * A 'Mu.Schema.Definition.Schema' with all the record -- 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. +-- * A 'Service' declaration containing all the methods +-- defined 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) + -> fail ("could not parse Avro IDL: " ++ show e) Right p -> avdlToDecls schemaName serviceName p @@ -88,20 +87,22 @@ 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] + [t| 'Package $(pkgType (A.ns protocol)) + '[ 'Service $(textToStrLit (A.pname protocol)) '[] + $(typesToList <$> mapM (avroMethodToType schemaName') + (S.toList $ A.messages protocol)) ] |] + pure [schemaDec, serviceDec] where - pkgType Nothing = [t| '[] |] + pkgType Nothing = [t| 'Nothing |] pkgType (Just (A.Namespace p)) - = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |] + = [t| 'Just $(textToStrLit (T.intercalate "." p)) |] schemaFromAvro :: [A.Schema] -> Q Type schemaFromAvro = (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls schemaDecFromAvroType :: A.Schema -> Q Type -schemaDecFromAvroType (A.Record name _ _ _ fields) = +schemaDecFromAvroType (A.Record name _ _ fields) = [t|'DRecord $(textToStrLit $ A.baseName name) $(typesToList <$> mapM avroFieldToType fields)|] where @@ -154,15 +155,15 @@ flattenAvroDecls = concatMap (uncurry (:) . flattenDecl) where flattenDecl :: A.Schema -> (A.Schema, [A.Schema]) - flattenDecl (A.Record name a d o fields) = + flattenDecl (A.Record name a d fields) = let (flds, tts) = unzip (flattenAvroField <$> fields) - in (A.Record name a d o flds, concat tts) + in (A.Record name a d flds, concat tts) flattenDecl (A.Union _) = error "should never happen, please, file an issue" flattenDecl t = (t, []) flattenAvroType :: A.Schema -> (A.Schema, [A.Schema]) - flattenAvroType (A.Record name a d o fields) = + flattenAvroType (A.Record name a d fields) = let (flds, tts) = unzip (flattenAvroField <$> fields) - in (A.NamedType name, A.Record name a d o flds : concat tts) + in (A.NamedType name, A.Record name a d flds : concat tts) flattenAvroType (A.Union (V.toList -> ts)) = let (us, tts) = unzip (map flattenAvroType ts) in (A.Union $ V.fromList us, concat tts) @@ -181,7 +182,7 @@ where argToType :: A.Argument -> Q Type argToType (A.Argument (A.NamedType a) _) - = [t| 'ArgSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |] + = [t| 'ArgSingle 'Nothing '[] ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |] argToType (A.Argument _ _) = fail "only named types may be used as arguments" @@ -189,7 +190,7 @@ retToType A.Null = [t| 'RetNothing |] retToType (A.NamedType a) - = [t| 'RetSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |] + = [t| 'RetSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |] retToType _ = fail "only named types may be used as results" @@ -197,4 +198,4 @@ typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT textToStrLit :: T.Text -> Q Type -textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s +textToStrLit s = litT $ strTyLit $ T.unpack s diff --git a/test/Avro.hs b/test/Avro.hs --- a/test/Avro.hs +++ b/test/Avro.hs @@ -8,7 +8,6 @@ import Data.Avro import qualified Data.ByteString.Lazy as BS -import Data.Functor.Identity import System.Environment import Mu.Adapter.Avro () @@ -19,12 +18,12 @@ exampleAddress = Address "1111BB" "Spain" examplePerson1, examplePerson2 :: Person -examplePerson1 = Person "Haskellio" "Gomez" (Just 30) (Just Male) exampleAddress -examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress +examplePerson1 = Person "Haskellio" "Gomez" (Just 30) (Just Male) exampleAddress [1,2,3] +examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress [] -deriving via (WithSchema Identity ExampleSchema "person" Person) instance HasAvroSchema Person -deriving via (WithSchema Identity ExampleSchema "person" Person) instance FromAvro Person -deriving via (WithSchema Identity ExampleSchema "person" Person) instance ToAvro Person +deriving via (WithSchema ExampleSchema "person" Person) instance HasAvroSchema Person +deriving via (WithSchema ExampleSchema "person" Person) instance FromAvro Person +deriving via (WithSchema ExampleSchema "person" Person) instance ToAvro Person main :: IO () main = do -- Obtain the filenames @@ -32,10 +31,10 @@ -- Read the file produced by Python putStrLn "haskell/consume" cbs <- BS.readFile conFile - let [people] = decodeContainer @Person cbs + let people = decodeContainer @Person cbs print people -- Encode a couple of values putStrLn "haskell/generate" print [examplePerson1, examplePerson2] - gbs <- encodeContainer [[examplePerson1, examplePerson2]] + gbs <- encodeContainer nullCodec [[examplePerson1, examplePerson2]] BS.writeFile genFile gbs diff --git a/test/avro/example.avsc b/test/avro/example.avsc --- a/test/avro/example.avsc +++ b/test/avro/example.avsc @@ -16,7 +16,8 @@ {"name": "lastName", "type": "string"}, {"name": "age", "type": ["long", "null"]}, {"name": "gender", "type": ["gender", "null"]}, - {"name": "address", "type": "address"} + {"name": "address", "type": "address"}, + {"name": "lucky_numbers", "type": { "type": "array", "items": "long" } } ] } ]