diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,31 @@ +# binary-tagged + +[![Build Status](https://travis-ci.org/phadej/binary-tagged.svg?branch=master)](https://travis-ci.org/phadej/binary-tagged) +[![Hackage](https://img.shields.io/hackage/v/binary-tagged.svg)](http://hackage.haskell.org/package/binary-tagged) + +Structurally tag binary serialisation stream. + +Say you have: + +```hs +data Record = Record + { _recordFields :: HM.HashMap Text (Integer, ByteString) + , _recordEnabled :: Bool + } + deriving (Eq, Show, Generic) + +instance Binary Record +instance HasStructuralInfo Record +instance HasSemanticVersion Record +``` + +then you can serialise and deserialise `Record` values with a structure tag by simply + +```hs +encodeTaggedFile "cachefile" record +decodeTaggedFile "cachefile" :: IO Record +``` + +If structure of `Record` changes in between, deserialisation will fail early. + +The overhead is next to non-observable, see [a simple benchmark](https://github.com/phadej/binary-tagged/blob/master/bench/Bench.hs) and the [results](https://rawgit.com/phadej/binary-tagged/master/bench.html). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveGeneric #-} +module Main (main) where + +import Control.DeepSeq +import Data.ByteString.Lazy as LBS +import Data.Binary.Orphans +import Data.Binary.Tagged +import Criterion.Main +import qualified Data.HashMap.Strict as HM +import Data.Text as T +import GHC.Generics + +data Field = Field + { _fieldName :: Text + , _fieldValue :: Int + } + deriving (Eq, Show, Generic) + +instance Binary Field +instance NFData Field +instance HasStructuralInfo Field + +data Record = Record + { _recordFields :: HM.HashMap Text Field + , _recordEnabled :: Bool + } + deriving (Eq, Show, Generic) + +instance Binary Record +instance NFData Record +instance HasStructuralInfo Record +instance HasSemanticVersion Record + +record :: Record +record = Record fields enabled + where fields = HM.fromList (fmap mkField [1..1000]) + mkField i = let name = T.pack (show i) + in (name, Field name i) + enabled = True + +encodedRecord :: LBS.ByteString +encodedRecord = encode record + +taggedEncodedRecord :: LBS.ByteString +taggedEncodedRecord = taggedEncode record + +main :: IO () +main = defaultMain + [ bgroup "encode" + [ bench "Binary" $ nf encode record + , bench "Tagged" $ nf taggedEncode record + ] + , bgroup "decode" + [ bench "Binary" $ nf (decode :: LBS.ByteString -> Record) encodedRecord + , bench "Tagged" $ nf (taggedDecode :: LBS.ByteString -> Record) taggedEncodedRecord + ] + ] diff --git a/binary-tagged.cabal b/binary-tagged.cabal new file mode 100644 --- /dev/null +++ b/binary-tagged.cabal @@ -0,0 +1,111 @@ +-- This file has been generated from package.yaml by hpack version 0.7.0. +-- +-- see: https://github.com/sol/hpack + +name: binary-tagged +version: 0.1.0.0 +synopsis: Tagged binary serialisation. +description: Write me. +category: Web +homepage: https://github.com/phadej/binary-tagged#readme +bug-reports: https://github.com/phadej/binary-tagged/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD3 +license-file: LICENSE +tested-with: GHC==7.8.4, GHC==7.10.2 +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/phadej/binary-tagged + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , generics-sop >=0.1 && <0.2 + , SHA >=1.6 && <1.7 + , array >=0.5 && <0.6 + , aeson >=0.8 && <0.10 + , binary >=0.7 && <0.8 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , hashable >=1.2 && <1.3 + , scientific >=0.3 && <0.4 + , tagged >=0.7 && <0.9 + , text >=1.2 && <1.3 + , time >=1.4 && <1.6 + , unordered-containers >=0.2 && <0.3 + , vector >=0.10 && <0.12 + exposed-modules: + Data.Binary.Tagged + default-language: Haskell2010 + +test-suite binary-tagged-test + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , generics-sop >=0.1 && <0.2 + , SHA >=1.6 && <1.7 + , array >=0.5 && <0.6 + , aeson >=0.8 && <0.10 + , binary >=0.7 && <0.8 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , hashable >=1.2 && <1.3 + , scientific >=0.3 && <0.4 + , tagged >=0.7 && <0.9 + , text >=1.2 && <1.3 + , time >=1.4 && <1.6 + , unordered-containers >=0.2 && <0.3 + , vector >=0.10 && <0.12 + , binary-tagged + , binary-orphans >=0.1.1 + , bifunctors + , quickcheck-instances + , tasty + , tasty-quickcheck + other-modules: + Generators + Rec1 + Rec2 + default-language: Haskell2010 + +benchmark binary-tagged-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: + bench + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , generics-sop >=0.1 && <0.2 + , SHA >=1.6 && <1.7 + , array >=0.5 && <0.6 + , aeson >=0.8 && <0.10 + , binary >=0.7 && <0.8 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , hashable >=1.2 && <1.3 + , scientific >=0.3 && <0.4 + , tagged >=0.7 && <0.9 + , text >=1.2 && <1.3 + , time >=1.4 && <1.6 + , unordered-containers >=0.2 && <0.3 + , vector >=0.10 && <0.12 + , binary-tagged + , binary-orphans >=0.1.1 + , deepseq + , criterion + default-language: Haskell2010 diff --git a/src/Data/Binary/Tagged.hs b/src/Data/Binary/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Tagged.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- We need this for Interleave +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Tagged +-- Copyright : (C) 2015 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus +-- +-- Structurally tag binary serialisation stream. +-- +-- Say you have: +-- +-- > data Record = Record +-- > { _recordFields :: HM.HashMap Text (Integer, ByteString) +-- > , _recordEnabled :: Bool +-- > } +-- > deriving (Eq, Show, Generic) +-- > +-- > instance Binary Record +-- > instance HasStructuralInfo Record +-- > instance HasSemanticVersion Record +-- +-- then you can serialise and deserialise @Record@ values with a structure tag by simply +-- +-- > encodeTaggedFile "cachefile" record +-- > decodeTaggedFile "cachefile" :: IO Record +-- +-- If structure of @Record@ changes in between, deserialisation will fail early. +module Data.Binary.Tagged + ( + -- * Data + BinaryTagged(..), + BinaryTagged', + binaryTag, + binaryTag', + binaryUntag, + binaryUntag', + StructuralInfo(..), + -- * Serialisation + taggedEncode, + taggedDecode, + taggedDecodeOrFail, + -- * IO functions for serialisation + taggedEncodeFile, + taggedDecodeFile, + taggedDecodeFileOrFail, + -- * Class + HasStructuralInfo(..), + HasSemanticVersion(..), + Version, + -- ** Type level calculations + Interleave, + SumUpTo, + -- * Generic derivation + -- ** GHC + ghcStructuralInfo, + ghcNominalType, + ghcStructuralInfo1, + -- ** SOP + sopStructuralInfo, + sopNominalType, + sopStructuralInfo1, + -- ** SOP direct + sopStructuralInfoS, + sopNominalTypeS, + sopStructuralInfo1S, + -- * Hash + structuralInfoSha1Digest, + structuralInfoSha1ByteStringDigest, + ) where + +import Control.Applicative +import Control.Monad +import Data.Binary +import Data.Binary.Get (ByteOffset) +import Data.ByteString as BS +import Data.ByteString.Lazy as LBS +import Data.Digest.Pure.SHA +import Data.Monoid ((<>)) +import Data.Proxy +import Generics.SOP as SOP +import Generics.SOP.GGP as SOP + +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +#endif + +import qualified GHC.Generics as GHC +import GHC.TypeLits + +-- Instances +import qualified Data.Vector as V +import qualified Data.Aeson as Aeson +import qualified Data.Monoid as Monoid +import Data.Int +import qualified Data.Text as S +import qualified Data.Text.Lazy as L +import qualified Data.Array.IArray as Array +import qualified Data.Array.Unboxed as Array +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.HashSet as HS +import qualified Data.HashMap.Lazy as HML +import qualified Data.Time as Time +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable as S + + +-- | 'Binary' serialisable class, which tries to be less error-prone to data structure changes. +-- +-- Values are serialised with header consisting of version @v@ and hash of 'structuralInfo'. +newtype BinaryTagged (v :: k) a = BinaryTagged { unBinaryTagged :: a } + deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, GHC.Generic, GHC.Generic1) +-- TODO: Derive Enum, Bounded, Typeable, Data, Hashable, NFData, Numeric classes? + +type BinaryTagged' a = BinaryTagged (SemanticVersion a) a + +binaryTag :: Proxy v -> a -> BinaryTagged v a +binaryTag _ = BinaryTagged + +binaryTag' :: HasSemanticVersion a => a -> BinaryTagged' a +binaryTag' = BinaryTagged + +binaryUntag :: Proxy v -> BinaryTagged v a -> a +binaryUntag _ = unBinaryTagged + +binaryUntag' :: HasSemanticVersion a => BinaryTagged' a -> a +binaryUntag' = unBinaryTagged + +-- | Tagged version of 'encode' +taggedEncode :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => a -> LBS.ByteString +taggedEncode = encode . binaryTag (Proxy :: Proxy (SemanticVersion a)) + +-- | Tagged version of 'decode' +taggedDecode :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => LBS.ByteString -> a +taggedDecode = binaryUntag (Proxy :: Proxy (SemanticVersion a)) . decode + +-- | Tagged version of 'decodeOrFail' +taggedDecodeOrFail :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) + => LBS.ByteString + -> Either (LBS.ByteString, ByteOffset, String) (LBS.ByteString, ByteOffset, a) +taggedDecodeOrFail = fmap3 (binaryUntag (Proxy :: Proxy (SemanticVersion a))) . decodeOrFail + where fmap3 f = fmap (\(a, b, c) -> (a, b, f c)) + +-- | Tagged version of 'encodeFile' +taggedEncodeFile :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => FilePath -> a -> IO () +taggedEncodeFile filepath = encodeFile filepath . binaryTag (Proxy :: Proxy (SemanticVersion a)) + +-- | Tagged version of 'decodeFile' +taggedDecodeFile :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => FilePath -> IO a +taggedDecodeFile = fmap (binaryUntag (Proxy :: Proxy (SemanticVersion a))) . decodeFile + +-- | Tagged version of 'decodeFileOrFail' +taggedDecodeFileOrFail :: forall a. (HasStructuralInfo a, HasSemanticVersion a, Binary a) => FilePath -> IO (Either (ByteOffset, String) a) +taggedDecodeFileOrFail = (fmap . fmap) (binaryUntag (Proxy :: Proxy (SemanticVersion a))) . decodeFileOrFail + +instance Applicative (BinaryTagged v) where + pure = return + (<*>) = ap + +instance Monad (BinaryTagged v) where + return = BinaryTagged + BinaryTagged m >>= k = k m + +instance Monoid.Monoid a => Monoid.Monoid (BinaryTagged v a) where + mempty = pure Monoid.mempty + mappend = liftA2 Monoid.mappend + +-- | Type the semantic version is serialised with. +type Version = Word32 + +-- | Version and structure hash are prepended to serialised stream +instance (Binary a, HasStructuralInfo a, KnownNat v) => Binary (BinaryTagged v a) where + put (BinaryTagged x) = put ver' >> put hash' >> put x + where + proxyV = Proxy :: Proxy v + proxyA = Proxy :: Proxy a + ver' = fromIntegral (natVal proxyV) :: Version + hash' = structuralInfoSha1ByteStringDigest . structuralInfo $ proxyA + + get = do + ver <- get + if ver == ver' + then do hash <- get + if hash == hash' + then fmap BinaryTagged get + else fail $ "Non matching structure hashes: got" <> show hash <> "; expected: " <> show hash' + else fail $ "Non matching versions: got " <> show ver <> "; expected: " <> show ver' + where + proxyV = Proxy :: Proxy v + proxyA = Proxy :: Proxy a + ver' = fromIntegral (natVal proxyV) :: Version + hash' = bytestringDigest . structuralInfoSha1Digest . structuralInfo $ proxyA + +-- | Data type structure, with (some) nominal information. +data StructuralInfo = NominalType String + | NominalNewtype String StructuralInfo + | StructuralInfo String [[StructuralInfo]] + deriving (Eq, Ord, Show, GHC.Generic) + +instance Binary StructuralInfo + +-- | Type class providing `StructuralInfo` for each data type. +-- +-- For regular non-recursive ADTs 'HasStructuralInfo' can be derived generically. +-- +-- > data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving (Generic) +-- > instance hasStructuralInfo Record +-- +-- For stable types, you can provide only type name +-- +-- > instance HasStructuralInfo Int where structuralInfo = ghcNominalType -- infer name from Generic information +-- > instance HasStructuralInfo Integer where structuralInfo _ = NominalType "Integer" +-- +-- Recursive type story is a bit sad atm. If the type structure is stable, you can do: +-- +-- > instance HasStructuralInfo a => HasStructuralInfo [a] where structuralInfo = ghcStructuralInfo1 +class HasStructuralInfo a where + structuralInfo :: Proxy a -> StructuralInfo + + default structuralInfo :: (GHC.Generic a, All2 HasStructuralInfo (GCode a), GDatatypeInfo a, SingI (GCode a)) => Proxy a -> StructuralInfo + structuralInfo = ghcStructuralInfo + +-- | A helper type family for 'encodeTaggedFile' and 'decodeTaggedFile'. +-- +-- The default definition is @'SemanticVersion' a = 0@ +class KnownNat (SemanticVersion a) => HasSemanticVersion (a :: *) where + type SemanticVersion a :: Nat + type SemanticVersion a = 0 + +instance HasStructuralInfo StructuralInfo +instance HasSemanticVersion StructuralInfo + +structuralInfoSha1Digest :: StructuralInfo -> Digest SHA1State +structuralInfoSha1Digest = sha1 . encode + +structuralInfoSha1ByteStringDigest :: StructuralInfo -> LBS.ByteString +structuralInfoSha1ByteStringDigest = bytestringDigest . structuralInfoSha1Digest + +-- Generic derivation + +ghcStructuralInfo :: (GHC.Generic a, All2 HasStructuralInfo (GCode a), GDatatypeInfo a, SingI (GCode a)) => Proxy a -> StructuralInfo +ghcStructuralInfo proxy = sopStructuralInfoS (gdatatypeInfo proxy) + +ghcNominalType :: (GHC.Generic a, GDatatypeInfo a) => Proxy a -> StructuralInfo +ghcNominalType proxy = sopNominalTypeS (gdatatypeInfo proxy) + +ghcStructuralInfo1 :: forall f a. (GHC.Generic1 f, GDatatypeInfo (f a), HasStructuralInfo a) => Proxy (f a) -> StructuralInfo +ghcStructuralInfo1 proxy = sopStructuralInfo1S (structuralInfo (Proxy :: Proxy a)) (gdatatypeInfo proxy) + +-- SOP derivation + +sopStructuralInfo :: forall a. (Generic a, HasDatatypeInfo a, All2 HasStructuralInfo (Code a)) => Proxy a -> StructuralInfo +sopStructuralInfo proxy = sopStructuralInfoS (datatypeInfo proxy) + +sopStructuralInfoS :: forall xss. (All2 HasStructuralInfo xss, SingI xss) => DatatypeInfo xss -> StructuralInfo +sopStructuralInfoS di@(Newtype _ _ ci) = NominalNewtype (datatypeName di) (sopNominalNewtype ci) +sopStructuralInfoS di@(ADT _ _ _) = StructuralInfo (datatypeName di) (sopNominalAdt (toNP' (sing :: Sing xss))) + +sopNominalNewtype :: forall x. HasStructuralInfo x => ConstructorInfo '[x] -> StructuralInfo +sopNominalNewtype _ = structuralInfo (Proxy :: Proxy x) + +sopNominalAdt :: (All2 HasStructuralInfo xss) => NP (NP Proxy) xss -> [[StructuralInfo]] +sopNominalAdt Nil = [] +sopNominalAdt (p :* ps) = sopStructuralInfoP p : sopNominalAdt ps + +sopStructuralInfoP :: (All HasStructuralInfo xs) => NP Proxy xs -> [StructuralInfo] +sopStructuralInfoP Nil = [] +sopStructuralInfoP (proxy :* rest) = structuralInfo proxy : sopStructuralInfoP rest + +sopNominalType :: forall a. (Generic a, HasDatatypeInfo a) => Proxy a -> StructuralInfo +sopNominalType proxy = sopNominalTypeS (datatypeInfo proxy) + +sopNominalTypeS :: DatatypeInfo xss -> StructuralInfo +sopNominalTypeS di = NominalType (datatypeName di) + +sopStructuralInfo1 :: forall f a. (Generic (f a), HasDatatypeInfo (f a), HasStructuralInfo a) => Proxy (f a) -> StructuralInfo +sopStructuralInfo1 proxy = sopStructuralInfo1S (structuralInfo (Proxy :: Proxy a)) (datatypeInfo proxy) + +sopStructuralInfo1S :: StructuralInfo -> DatatypeInfo xss -> StructuralInfo +sopStructuralInfo1S nsop di = NominalNewtype (datatypeName di) nsop + +-- SOP helpers + +datatypeName :: DatatypeInfo xss -> DatatypeName +datatypeName (Newtype _ d _) = d +datatypeName (ADT _ d _) = d + +toNP :: Sing xs -> NP Proxy xs +toNP SNil = Nil +toNP SCons = Proxy :* toNP sing + +toNP' :: Sing xss -> NP (NP Proxy) xss +toNP' SNil = Nil +toNP' SCons = toNP sing :* toNP' sing + +-- | Interleaving +-- +-- > 3 | 9 . . . . +-- > 2 | 5 8 . . . +-- > 1 | 2 4 7 11 . +-- > 0 | 0 1 3 6 10 +-- > ----------------- +-- > 0 1 2 3 4 +-- +-- This can be calculated by @f x y = sum ([0..x+y]) + y@ +type Interleave (n :: Nat) (m :: Nat) = SumUpTo (n + m) + m +type SumUpTo (n :: Nat) = n * (n - 1) + +-- Instances + +instance HasStructuralInfo Bool where structuralInfo = ghcNominalType +instance HasStructuralInfo Char where structuralInfo = ghcNominalType +instance HasStructuralInfo Int where structuralInfo = ghcNominalType +instance HasStructuralInfo Integer where structuralInfo _ = NominalType "Integer" + +instance HasStructuralInfo Int8 where structuralInfo _ = NominalType "Int8" +instance HasStructuralInfo Int16 where structuralInfo _ = NominalType "Int16" +instance HasStructuralInfo Int32 where structuralInfo _ = NominalType "Int32" +instance HasStructuralInfo Int64 where structuralInfo _ = NominalType "Int64" + +instance HasStructuralInfo Word8 where structuralInfo _ = NominalType "Word8" +instance HasStructuralInfo Word16 where structuralInfo _ = NominalType "Word16" +instance HasStructuralInfo Word32 where structuralInfo _ = NominalType "Word32" +instance HasStructuralInfo Word64 where structuralInfo _ = NominalType "Word64" + +-- Recursive types +instance HasStructuralInfo a => HasStructuralInfo [a] where structuralInfo = ghcStructuralInfo1 +instance HasSemanticVersion a => HasSemanticVersion [a] where + type SemanticVersion [a] = SemanticVersion a + +-- Types from base +instance HasStructuralInfo a => HasStructuralInfo (Maybe a) +instance HasSemanticVersion a => HasSemanticVersion (Maybe a) where + type SemanticVersion (Maybe a) = SemanticVersion a + +instance (HasStructuralInfo a, HasStructuralInfo b) => HasStructuralInfo (Either a b) +instance (HasSemanticVersion a, HasSemanticVersion b, KnownNat (SemanticVersion (Either a b))) => HasSemanticVersion (Either a b) where + type SemanticVersion (Either a b) = Interleave (SemanticVersion a) (SemanticVersion b) + +-- Tuples +instance (HasStructuralInfo a, HasStructuralInfo b) => HasStructuralInfo (a, b) +instance (HasStructuralInfo a, HasStructuralInfo b, HasStructuralInfo c) => HasStructuralInfo (a, b, c) +instance (HasStructuralInfo a, HasStructuralInfo b, HasStructuralInfo c, HasStructuralInfo d) => HasStructuralInfo (a, b, c, d) + +-- Monoid +instance HasStructuralInfo a => HasStructuralInfo (Monoid.Sum a) +instance HasSemanticVersion a => HasSemanticVersion (Monoid.Sum a) where + type SemanticVersion (Monoid.Sum a) = SemanticVersion a + +instance HasStructuralInfo a => HasStructuralInfo (Monoid.Product a) +instance HasSemanticVersion a => HasSemanticVersion (Monoid.Product a) where + type SemanticVersion (Monoid.Product a) = SemanticVersion a + +-- TODO: add more + +-- ByteString +instance HasStructuralInfo BS.ByteString where structuralInfo _ = NominalType "ByteString.Strict" +instance HasStructuralInfo LBS.ByteString where structuralInfo _ = NominalType "ByteString.Lazy" + +instance HasSemanticVersion BS.ByteString +instance HasSemanticVersion LBS.ByteString + +-- Text +instance HasStructuralInfo S.Text where structuralInfo _ = NominalType "Text.Strict" +instance HasStructuralInfo L.Text where structuralInfo _ = NominalType "Text.Lazy" + +instance HasSemanticVersion S.Text +instance HasSemanticVersion L.Text + +-- Containers +instance HasStructuralInfo a => HasStructuralInfo (IntMap.IntMap a) where + structuralInfo _ = NominalNewtype "IntMap" $ structuralInfo (Proxy :: Proxy a) +instance HasSemanticVersion a => HasSemanticVersion (IntMap.IntMap a) where + type SemanticVersion (IntMap.IntMap a) = SemanticVersion a + +instance HasStructuralInfo IntSet.IntSet where + structuralInfo _ = NominalType "IntSet" +instance HasSemanticVersion IntSet.IntSet + +instance (HasStructuralInfo k, HasStructuralInfo v) => HasStructuralInfo (Map.Map k v) where + structuralInfo _ = StructuralInfo "Map" [[ structuralInfo (Proxy :: Proxy k), structuralInfo (Proxy :: Proxy v) ]] +instance (HasSemanticVersion k, HasSemanticVersion v, KnownNat (SemanticVersion (Map.Map k v))) => HasSemanticVersion (Map.Map k v) where + type SemanticVersion (Map.Map k v) = Interleave (SemanticVersion k) (SemanticVersion v) + +instance HasStructuralInfo a => HasStructuralInfo (Seq.Seq a) where + structuralInfo _ = NominalNewtype "Seq" $ structuralInfo (Proxy :: Proxy a) +instance HasSemanticVersion a => HasSemanticVersion (Seq.Seq a) where + type SemanticVersion (Seq.Seq a) = SemanticVersion a + +instance HasStructuralInfo a => HasStructuralInfo (Set.Set a) where + structuralInfo _ = NominalNewtype "Set" $ structuralInfo (Proxy :: Proxy a) +instance HasSemanticVersion a => HasSemanticVersion (Set.Set a) where + type SemanticVersion (Set.Set a) = SemanticVersion a + +-- Unordered containers + +instance (HasStructuralInfo k, HasStructuralInfo v) => HasStructuralInfo (HML.HashMap k v) where + structuralInfo _ = StructuralInfo "HashMap" [[ structuralInfo (Proxy :: Proxy k), structuralInfo (Proxy :: Proxy v) ]] +instance (HasSemanticVersion k, HasSemanticVersion v, KnownNat (SemanticVersion (HML.HashMap k v))) => HasSemanticVersion (HML.HashMap k v) where + type SemanticVersion (HML.HashMap k v) = Interleave (SemanticVersion k) (SemanticVersion v) + +instance HasStructuralInfo a => HasStructuralInfo (HS.HashSet a) where + structuralInfo _ = NominalNewtype "HashSet" $ structuralInfo (Proxy :: Proxy a) +instance HasSemanticVersion a => HasSemanticVersion (HS.HashSet a) where + type SemanticVersion (HS.HashSet a) = SemanticVersion a + +-- Array +instance (HasStructuralInfo i, HasStructuralInfo e) => HasStructuralInfo (Array.Array i e) where + structuralInfo _ = StructuralInfo "Array" [[ structuralInfo (Proxy :: Proxy i), structuralInfo (Proxy :: Proxy e) ]] +instance (HasSemanticVersion i, HasSemanticVersion e, KnownNat (SemanticVersion (Array.Array i e))) => HasSemanticVersion (Array.Array i e) where + type SemanticVersion (Array.Array i e) = Interleave (SemanticVersion i) (SemanticVersion e) + +instance (HasStructuralInfo i, HasStructuralInfo e) => HasStructuralInfo (Array.UArray i e) where + structuralInfo _ = StructuralInfo "UArray" [[ structuralInfo (Proxy :: Proxy i), structuralInfo (Proxy :: Proxy e) ]] +instance (HasSemanticVersion i, HasSemanticVersion e, KnownNat (SemanticVersion (Array.UArray i e))) => HasSemanticVersion (Array.UArray i e) where + type SemanticVersion (Array.UArray i e) = Interleave (SemanticVersion i) (SemanticVersion e) + +-- Vector + +instance HasStructuralInfo a => HasStructuralInfo (V.Vector a) where + structuralInfo _ = NominalNewtype "Vector" $ structuralInfo (Proxy :: Proxy a) +instance HasSemanticVersion a => HasSemanticVersion (V.Vector a) where + type SemanticVersion (V.Vector a) = SemanticVersion a + +instance HasStructuralInfo a => HasStructuralInfo (U.Vector a) where + structuralInfo _ = NominalNewtype "Vector.Unboxed" $ structuralInfo (Proxy :: Proxy a) +instance HasSemanticVersion a => HasSemanticVersion (U.Vector a) where + type SemanticVersion (U.Vector a) = SemanticVersion a + +instance HasStructuralInfo a => HasStructuralInfo (S.Vector a) where + structuralInfo _ = NominalNewtype "Vector.Storable" $ structuralInfo (Proxy :: Proxy a) +instance HasSemanticVersion a => HasSemanticVersion (S.Vector a) where + type SemanticVersion (S.Vector a) = SemanticVersion a + +-- Time + +instance HasStructuralInfo Time.UTCTime where structuralInfo _ = NominalType "UTCTime" +instance HasStructuralInfo Time.DiffTime where structuralInfo _ = NominalType "DiffTime" +instance HasStructuralInfo Time.UniversalTime where structuralInfo _ = NominalType "UniversalTime" +instance HasStructuralInfo Time.NominalDiffTime where structuralInfo _ = NominalType "NominalDiffTime" +instance HasStructuralInfo Time.Day where structuralInfo _ = NominalType "Day" +instance HasStructuralInfo Time.TimeZone where structuralInfo _ = NominalType "TimeZone" +instance HasStructuralInfo Time.TimeOfDay where structuralInfo _ = NominalType "TimeOfDay" +instance HasStructuralInfo Time.LocalTime where structuralInfo _ = NominalType "LocalTime" + +instance HasSemanticVersion Time.UTCTime +instance HasSemanticVersion Time.DiffTime +instance HasSemanticVersion Time.UniversalTime +instance HasSemanticVersion Time.NominalDiffTime +instance HasSemanticVersion Time.Day +instance HasSemanticVersion Time.TimeZone +instance HasSemanticVersion Time.TimeOfDay +instance HasSemanticVersion Time.LocalTime + +-- Value + +-- TODO: derive sop +instance HasStructuralInfo Aeson.Value where structuralInfo _ = NominalType "Aeson.Value" +instance HasSemanticVersion Aeson.Value diff --git a/test/Generators.hs b/test/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Generators.hs @@ -0,0 +1,10 @@ +module Generators where + +import Data.Monoid +import Test.Tasty.QuickCheck + +arbitrarySum :: Arbitrary a => Gen (Sum a) +arbitrarySum = fmap Sum arbitrary + +arbitraryProduct :: Arbitrary a => Gen (Product a) +arbitraryProduct = fmap Product arbitrary diff --git a/test/Rec1.hs b/test/Rec1.hs new file mode 100644 --- /dev/null +++ b/test/Rec1.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +module Rec1 where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Data.Binary.Orphans +import Data.Binary.Tagged +import Data.Monoid +import GHC.Generics +import Test.Tasty.QuickCheck + +import Generators + +data Rec = Rec (Sum Int) (Product Int) + deriving (Eq, Show, Generic) + +instance Binary Rec +instance HasStructuralInfo Rec +instance HasSemanticVersion Rec + +instance Arbitrary Rec where + arbitrary = Rec <$> arbitrarySum <*> arbitraryProduct diff --git a/test/Rec2.hs b/test/Rec2.hs new file mode 100644 --- /dev/null +++ b/test/Rec2.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +module Rec2 where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Data.Binary.Orphans +import Data.Binary.Tagged +import Data.Monoid +import GHC.Generics +import Test.Tasty.QuickCheck + +import Generators + +data Rec = Rec (Product Int) (Sum Int) + deriving (Eq, Show, Generic) + +instance Binary Rec +instance HasStructuralInfo Rec +instance HasSemanticVersion Rec + +instance Arbitrary Rec where + arbitrary = Rec <$> arbitraryProduct <*> arbitrarySum diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main (main) where + +import Data.Bifunctor +import Data.Binary +import Data.Binary.Tagged +import Data.Either +import Data.Monoid +import Data.Proxy +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Rec1 +import qualified Rec2 + +main :: IO () +main = defaultMain $ testGroup "Tests" + [ roundtrips + , wrongRoundtrips + , failedRoundtrips + ] + +instance Arbitrary a => Arbitrary (BinaryTagged v a) where + arbitrary = fmap BinaryTagged arbitrary + +proxyRec1 :: Proxy Rec1.Rec +proxyRec1 = Proxy + +proxyRec1Ver0 :: Proxy (BinaryTagged 0 Rec1.Rec) +proxyRec1Ver0 = Proxy + +proxyRec1Ver1 :: Proxy (BinaryTagged 1 Rec1.Rec) +proxyRec1Ver1 = Proxy + +proxyRec2 :: Proxy Rec2.Rec +proxyRec2 = Proxy + +proxyRec2Ver0 :: Proxy (BinaryTagged 0 Rec2.Rec) +proxyRec2Ver0 = Proxy + +proxyRec2Ver1 :: Proxy (BinaryTagged 1 Rec2.Rec) +proxyRec2Ver1 = Proxy + +eqRec1Rec2 :: Rec1.Rec -> Rec2.Rec -> Bool +eqRec1Rec2 (Rec1.Rec (Sum a) (Product b)) (Rec2.Rec (Product a') (Sum b')) = + a == a' && b == b' + +roundtrips :: TestTree +roundtrips = testGroup "Roundtrip" + [ testProperty "Rec1" $ roundtrip proxyRec1 + , testProperty "BinaryTagged 0 Rec1" $ roundtrip proxyRec1Ver0 + , testProperty "BinaryTagged 1 Rec1" $ roundtrip proxyRec1Ver1 + , testProperty "Rec2" $ roundtrip proxyRec2 + , testProperty "BinaryTagged 0 Rec2" $ roundtrip proxyRec2Ver0 + , testProperty "BinaryTagged 1 Rec2" $ roundtrip proxyRec2Ver1 + ] + +wrongRoundtrips :: TestTree +wrongRoundtrips = testGroup "Decode successful, data invalid" + [ testProperty "Rec1 -> Rec2" $ wrongRoundtrip eqRec1Rec2 + , testProperty "Rec2 -> Rec1" $ wrongRoundtrip eqRec1Rec2 + ] + +failedRoundtrips :: TestTree +failedRoundtrips = testGroup "Failed roundtrips" + [ testProperty "Different version" $ failedRoundtrip proxyRec1Ver0 proxyRec1Ver1 + , testProperty "Different structure" $ failedRoundtrip proxyRec1Ver0 proxyRec2Ver0 + ] + +roundtrip :: (Eq a, Show a, Arbitrary a, Binary a) => Proxy a -> a -> Property +roundtrip _ x = x === decode (encode x) + +wrongRoundtrip :: (Arbitrary a, Binary a, Binary b) => (a -> b -> Bool) -> a -> Property +wrongRoundtrip eq x = property $ eq x $ decode (encode x) + +trdOf3 :: (a, b, c) -> c +trdOf3 (_, _, c) = c + +isLeftProperty :: (Show a, Show b) => Either a b -> Property +isLeftProperty x = counterexample ("not isLeft: " <> show x) (isLeft x) + +failedRoundtrip :: forall a b. (Arbitrary a, Binary a, Binary b, Show b) => Proxy a -> Proxy b -> a -> Property +failedRoundtrip _ _ x = let x' = bimap trdOf3 trdOf3 $ decodeOrFail (encode x) :: Either String b + in isLeftProperty x'