diff --git a/avro.cabal b/avro.cabal --- a/avro.cabal +++ b/avro.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: avro -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Avro serialization support for Haskell description: Avro serialization and deserialization support for Haskell homepage: https://github.com/haskell-works/hw-haskell-avro.git @@ -56,13 +56,13 @@ fail, hashable, mtl, + pure-zlib, scientific, + semigroups, + tagged, text, unordered-containers, - vector, - pure-zlib, - semigroups, - tagged + vector if flag(templateHaskell) build-depends: template-haskell >= 2.4 @@ -84,6 +84,7 @@ , Avro.Codec.BoolSpec , Avro.Codec.CodecRawSpec , Avro.Codec.DoubleSpec + , Avro.Codec.FloatSpec , Avro.Codec.Int64Spec , Avro.Codec.MaybeSpec , Avro.Codec.NestedSpec @@ -93,9 +94,10 @@ , Avro.ToAvroSpec build-depends: base >=4.6 && < 5 - , avro , aeson + , lens-aeson , array + , avro , base16-bytestring , binary , bytestring @@ -104,16 +106,18 @@ , extra , fail , hashable + , hspec + , lens , mtl + , pure-zlib + , QuickCheck , scientific + , semigroups + , tagged , text + , transformers , unordered-containers , vector - , pure-zlib - , semigroups - , tagged - , hspec - , QuickCheck if flag(templateHaskell) build-depends: template-haskell diff --git a/src/Data/Avro.hs b/src/Data/Avro.hs --- a/src/Data/Avro.hs +++ b/src/Data/Avro.hs @@ -74,7 +74,7 @@ , HasAvroSchema(..) , Avro , (.:) - , (.=), record + , (.=), record, fixed , Result(..), badValue , decode , decodeWithSchema @@ -178,7 +178,8 @@ record :: Foldable f => Type -> f (Text,T.Value Type) -> T.Value Type record ty = T.Record ty . HashMap.fromList . toList - +fixed :: Type -> B.ByteString -> T.Value Type +fixed = T.Fixed -- @enumToAvro val@ will generate an Avro encoded value of enum suitable -- for serialization ('encode'). -- enumToAvro :: (Show a, Enum a, Bounded a, Generic a) => a -> T.Value Type diff --git a/src/Data/Avro/Decode.hs b/src/Data/Avro/Decode.hs --- a/src/Data/Avro/Decode.hs +++ b/src/Data/Avro/Decode.hs @@ -161,7 +161,7 @@ case unionLookup i of Nothing -> fail $ "Decoded Avro tag is outside the expected range for a Union. Tag: " <> show i <> " union of: " <> show (P.map typeName $ NE.toList ts) Just t -> T.Union ts t <$> go t - Fixed {..} -> T.Fixed <$> G.getByteString (fromIntegral size) + Fixed {..} -> T.Fixed ty <$> G.getByteString (fromIntegral size) getKVBlocks :: Type -> Get [[(Text,T.Value Type)]] getKVBlocks t = 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 @@ -27,6 +27,7 @@ import Data.Avro.Deriving.NormSchema +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBSC8 import Data.Text (Text) @@ -75,6 +76,11 @@ fromAvro (AT.Record _ r) = $(genFromAvroFieldsExp (mkTextName $ unTN n) fs) r fromAvro value = $( [|\v -> badValue v $(mkTextLit $ unTN 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 _ = pure [] genFromAvroFieldsExp :: Name -> [Field] -> Q Exp @@ -99,7 +105,7 @@ |] genToAvro :: Schema -> Q [Dec] -genToAvro s@(Enum n _ _ _ vs _) = do +genToAvro s@(Enum n _ _ _ vs _) = toAvroInstance (mkSchemaValueName n) where conP' = flip conP [] . mkAdtCtorName n @@ -125,6 +131,16 @@ ) |] +genToAvro s@(Fixed n _ _ size) = + toAvroInstance (mkSchemaValueName n) + where + toAvroInstance sname = + [d| instance ToAvro $(conT $ mkDataTypeName n) where + toAvro = $(do + x <- newName "x" + lamE [conP (mkDataTypeName n) [varP x]] [| AT.Fixed $(varE sname) $(varE x) |]) + |] + schemaDef :: Name -> Schema -> Q [Dec] schemaDef sname sch = setName sname $ [d| @@ -150,13 +166,17 @@ 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 + 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| Int |] + S.Int -> [t| Int32 |] S.Float -> [t| Float |] S.Double -> [t| Double |] S.Bytes -> [t| ByteString |] @@ -212,6 +232,27 @@ ftype <- mkFieldTypeName (fldType field) let fName = mkFieldTextName prefix field pure (fName, defaultStrictness, ftype) + +genNewtype :: Name -> Q Dec +#if MIN_VERSION_template_haskell(2,12,0) +genNewtype dn = do + ders <- sequenceA [[t|Eq|], [t|Show|]] + fldType <- [t|ByteString|] + let ctor = RecC dn [(mkName ("un" ++ nameBase dn), defaultStrictness, fldType)] + pure $ NewtypeD [] dn [] Nothing ctor [DerivClause Nothing ders] +#elif MIN_VERSION_template_haskell(2,11,0) +genNewtype dn = do + ders <- sequenceA [[t|Eq|], [t|Show|]] + fldType <- [t|ByteString|] + let ctor = RecC dn [(mkName ("un" ++ nameBase dn), defaultStrictness, fldType)] + pure $ NewtypeD [] dn [] Nothing ctor ders +#else +genNewtype dn = do + [ConT eq, ConT sh] <- sequenceA [[t|Eq|], [t|Show|]] + fldType <- [t|ByteString|] + let ctor = RecC dn [(mkName ("un" ++ nameBase dn), defaultStrictness, fldType)] + pure $ NewtypeD [] dn [] ctor [eq, sh] +#endif genEnum :: Name -> [Name] -> Q Dec #if MIN_VERSION_template_haskell(2,12,0) 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 @@ -28,6 +28,7 @@ Union (t1 :| ts) _ -> getTypes t1 <> concatMap getTypes ts Map t -> getTypes t e@Enum{} -> [e] + f@Fixed{} -> [f] _ -> [] -- TODO: Currently ensures normalisation: only in one way diff --git a/src/Data/Avro/Encode.hs b/src/Data/Avro/Encode.hs --- a/src/Data/Avro/Encode.hs +++ b/src/Data/Avro/Encode.hs @@ -233,5 +233,10 @@ case DL.elemIndex sel (NE.toList opts) of Just idx -> AvroM (putI idx <> putAvro val, S.mkUnion opts) Nothing -> error "Union encoding specifies type not found in schema" - T.Fixed bs -> avro bs T.Enum sch@S.Enum{..} ix t -> AvroM (putI ix, sch) + T.Fixed ty bs -> + if (B.length bs == size ty) + then AvroM (byteString bs, S.Bytes) + else error $ "Fixed type " <> show (name ty) + <> " has size " <> show (size ty) + <> " but the value has length " <> show (B.length bs) 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 @@ -70,6 +70,11 @@ instance FromAvro Double where fromAvro (T.Double d) = pure d fromAvro v = badValue v "Double" + +instance FromAvro Float where + fromAvro (T.Float f) = pure f + fromAvro v = badValue v "Float" + instance FromAvro a => FromAvro (Maybe a) where fromAvro (T.Union (S.Null :| [_]) _ T.Null) = pure Nothing fromAvro (T.Union (S.Null :| [_]) _ v) = Just <$> fromAvro v diff --git a/src/Data/Avro/HasAvroSchema.hs b/src/Data/Avro/HasAvroSchema.hs --- a/src/Data/Avro/HasAvroSchema.hs +++ b/src/Data/Avro/HasAvroSchema.hs @@ -45,6 +45,9 @@ instance HasAvroSchema Double where schema = Tagged S.Double +instance HasAvroSchema Float where + schema = Tagged S.Float + instance HasAvroSchema Text.Text where schema = Tagged S.String 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 @@ -95,7 +95,7 @@ | Fixed { name :: TypeName , namespace :: Maybe Text , aliases :: [TypeName] - , size :: Integer + , size :: Int } deriving (Show) @@ -320,7 +320,7 @@ Ty.Record _ flds -> A.Object (HashMap.map toJSON flds) Ty.Union _ _ Ty.Null -> A.Null Ty.Union _ ty val -> object [ typeName ty .= val ] - Ty.Fixed bs -> A.String ("\\u" <> T.decodeUtf8 (Base16.encode bs)) -- XXX the example wasn't literal - this should be an actual bytestring... somehow. + Ty.Fixed _ bs -> A.String ("\\u" <> T.decodeUtf8 (Base16.encode bs)) -- XXX the example wasn't literal - this should be an actual bytestring... somehow. Ty.Enum _ _ txt -> A.String txt data Result a = Success a | Error String @@ -486,36 +486,3 @@ Fixed {..} -> mk name aliases namespace Array {..} -> go item _ -> [] - --- TODO: Currently ensures normalisation: only in one way --- that is needed for "extractRecord". --- it ensures that an "extracted" record is self-contained and --- all the named types are resolvable within the scope of the schema. --- The other way around (to each record is inlined only once and is referenced --- as a named type after that) is not implemented. -normSchema :: [Schema] -- ^ List of all possible records - -> Schema -- ^ Schema to normalise - -> State (S.Set TypeName) Schema -normSchema rs r = case r of - t@(NamedType tn) -> do - let sn = shortName tn - resolved <- get - if S.member sn resolved - then pure t - else do - modify' (S.insert sn) - pure $ fromMaybe (error $ "Unable to resolve schema: " <> show (typeName t)) (findSchema tn) - - Array s -> Array <$> normSchema rs s - Map s -> Map <$> normSchema rs s - Record{name = tn} -> do - let sn = shortName tn - modify' (S.insert sn) - flds <- mapM (\fld -> setType fld <$> normSchema rs (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) - findSchema tn = L.find (\s -> name s == tn || fullName s == tn) rs 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 @@ -47,6 +47,9 @@ instance ToAvro Double where toAvro = T.Double +instance ToAvro Float where + toAvro = T.Float + instance ToAvro Text.Text where toAvro = T.String diff --git a/src/Data/Avro/Types.hs b/src/Data/Avro/Types.hs --- a/src/Data/Avro/Types.hs +++ b/src/Data/Avro/Types.hs @@ -20,6 +20,6 @@ | Map (HashMap Text (Value f)) -- ^ Dynamically enforced monomorphic type | Record f (HashMap Text (Value f)) -- Order and a map | Union (NonEmpty f) f (Value f) -- ^ Set of union options, schema for selected option, and the actual value. - | Fixed {-# UNPACK #-} !ByteString + | Fixed f {-# UNPACK #-} !ByteString | Enum f {-# UNPACK #-} !Int Text -- ^ An enum is a set of the possible symbols (the schema) and the selected symbol deriving (Eq, Show) diff --git a/test/Avro/Codec/FloatSpec.hs b/test/Avro/Codec/FloatSpec.hs new file mode 100644 --- /dev/null +++ b/test/Avro/Codec/FloatSpec.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Avro.Codec.FloatSpec (spec) where + +import Data.Avro +import Data.Avro.Schema +import Data.Tagged +import Test.Hspec +import qualified Data.Avro.Types as AT +import qualified Data.ByteString.Lazy as BL +import qualified Test.QuickCheck as Q + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +newtype OnlyFloat = OnlyFloat + {onlyFloatValue :: Float + } deriving (Show, Eq) + +onlyFloatSchema :: Schema +onlyFloatSchema = + let fld nm = Field nm [] Nothing Nothing + in Record "OnlyFloat" (Just "test.contract") [] Nothing Nothing + [ fld "onlyFloatValue" Float Nothing + ] + +instance HasAvroSchema OnlyFloat where + schema = pure onlyFloatSchema + +instance ToAvro OnlyFloat where + toAvro sa = record onlyFloatSchema + [ "onlyFloatValue" .= onlyFloatValue sa ] + +instance FromAvro OnlyFloat where + fromAvro (AT.Record _ r) = + OnlyFloat <$> r .: "onlyFloatValue" + +spec :: Spec +spec = describe "Avro.Codec.FloatSpec" $ do + it "Can decode 0.89" $ do + let expectedBuffer = BL.pack [10, -41, 99, 63] + let value = OnlyFloat 0.89 + encode value `shouldBe` expectedBuffer + + it "Can decode -2.0" $ do + let expectedBuffer = BL.pack [0, 0, 0, -64] + let value = OnlyFloat (-2.0) + encode value `shouldBe` expectedBuffer + + it "Can decode 1.0" $ do + let expectedBuffer = [0, 0, 128, 63] + let value = OnlyFloat 1.0 + BL.unpack (encode value) `shouldBe` expectedBuffer + + it "Can decode encoded Float values" $ do + Q.property $ \(d :: Float) -> + decode (encode (OnlyFloat d)) == Success (OnlyFloat d) 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 @@ -19,7 +19,7 @@ import qualified Data.Avro.Types as AT import qualified Data.ByteString.Lazy as BL import qualified Test.QuickCheck as Q -import Debug.Trace + {-# ANN module ("HLint: ignore Redundant do" :: String) #-} diff --git a/test/Avro/THSimpleSpec.hs b/test/Avro/THSimpleSpec.hs --- a/test/Avro/THSimpleSpec.hs +++ b/test/Avro/THSimpleSpec.hs @@ -5,11 +5,17 @@ where import Control.Monad -import Data.Aeson (decodeStrict) +import Control.Lens +import Data.Aeson.Lens import Data.Avro import Data.Avro.Deriving import Data.Avro.Schema -import Data.ByteString as BS +import Data.Monoid ((<>)) +import qualified Data.Aeson as J +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Base16 as Base16 import Test.Hspec @@ -21,16 +27,22 @@ spec = describe "Avro.THSpec: Small Schema" $ do let msgs = [ Endpoint - { endpointIps = ["192.168.1.1", "127.0.0.1"] - , endpointPorts = [PortRange 1 10, PortRange 11 20] + { endpointIps = ["192.168.1.1", "127.0.0.1"] + , endpointPorts = [PortRange 1 10, PortRange 11 20] + , endpointOpaque = Opaque "16-b-long-string" + , endpointCorrelation = Opaque "opaq-correlation" + , endpointTag = Left 14 } , Endpoint - { endpointIps = [] - , endpointPorts = [PortRange 1 10, PortRange 11 20] + { endpointIps = [] + , endpointPorts = [PortRange 1 10, PortRange 11 20] + , endpointOpaque = Opaque "opaque-long-text" + , endpointCorrelation = Opaque "correlation-data" + , endpointTag = Right "first-tag" } ] - it "should do roundtrip" $ do + it "should do roundtrip" $ forM_ msgs $ \msg -> fromAvro (toAvro msg) `shouldBe` pure msg @@ -39,4 +51,17 @@ let encoded = encode msg let decoded = decode encoded - pure msg `shouldBe` decoded + decoded `shouldBe` pure msg + + it "should convert to JSON" $ do + forM_ msgs $ \msg -> do + let json = J.encode (toAvro msg) + json ^? key "opaque" . _String `shouldBe` Just (encodeOpaque $ endpointOpaque msg) + json ^? key "correlation" . _String `shouldBe` Just (encodeOpaque $ endpointCorrelation msg) + + json ^? key "tag" . _Value . key "int" . _Integral `shouldBe` endpointTag msg ^? _Left + json ^? key "tag" . _Value . key "string" . _String `shouldBe` endpointTag msg ^? _Right + where + encodeOpaque :: Opaque -> Text + encodeOpaque v = "\\u" <> T.decodeUtf8 (Base16.encode $ unOpaque v) + diff --git a/test/Avro/ToAvroSpec.hs b/test/Avro/ToAvroSpec.hs --- a/test/Avro/ToAvroSpec.hs +++ b/test/Avro/ToAvroSpec.hs @@ -24,6 +24,8 @@ , tmTimestamp :: Maybe Int64 , tmForeignId :: Maybe Int64 , tmCompetence :: Maybe Double + , tmRelevance :: Maybe Float + , tmSeverity :: Float , tmAttraction :: Double } deriving (Show, Eq) @@ -36,6 +38,8 @@ , fld "timestamp" (mkUnion (Null :| [Long])) Nothing , fld "foreignId" (mkUnion (Null :| [Long])) Nothing , fld "competence" (mkUnion (Null :| [Double])) Nothing + , fld "relevance" (mkUnion (Null :| [Float])) Nothing + , fld "severity" Float Nothing , fld "attraction" Double Nothing ] @@ -49,6 +53,8 @@ , "timestamp" .= tmTimestamp m , "foreignId" .= tmForeignId m , "competence" .= tmCompetence m + , "relevance" .= tmRelevance m + , "severity" .= tmSeverity m , "attraction" .= tmAttraction m ] @@ -59,6 +65,8 @@ <*> r .: "timestamp" <*> r .: "foreignId" <*> r .: "competence" + <*> r .: "relevance" + <*> r .: "severity" <*> r .: "attraction" fromAvro v = badValue v "TypesTestMessage" @@ -69,6 +77,8 @@ , tmTimestamp = Just 7 , tmForeignId = Nothing , tmCompetence = Just 7.5 + , tmRelevance = Just 3.8 + , tmSeverity = -255.77 , tmAttraction = 8.974 } diff --git a/test/data/small.avsc b/test/data/small.avsc --- a/test/data/small.avsc +++ b/test/data/small.avsc @@ -3,11 +3,14 @@ "name": "Endpoint", "fields": [ { + "name": "opaque", + "type": { "name": "Opaque", "type": "fixed", "size": 16 } + }, + { "name": "correlation", "type": "Opaque" }, + { "name": "tag", "type": ["int", "string"] }, + { "name": "ips", - "type": { - "type": "array", - "items": "string" - } + "type": { "type": "array", "items": "string" } }, { "name": "ports", @@ -17,14 +20,8 @@ "type": "record", "name": "PortRange", "fields": [ - { - "name": "start", - "type": "int" - }, - { - "name": "end", - "type": "int" - } + { "name": "start", "type": "int" }, + { "name": "end", "type": "int" } ] } }