diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,10 @@ +# Changelog for safe-json + +## 0.1.0 + +* First release. Includes: + * Data.Aeson.Safe + * Data.SafeJSON + * Data.SafeJSON.Instances + * Data.SafeJSON.Internal + * Data.SafeJSON.Test diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Felix Paulusma + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,1 @@ +Please see README at https://github.com/Vlix/safe-json#readme 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/safe-json.cabal b/safe-json.cabal new file mode 100644 --- /dev/null +++ b/safe-json.cabal @@ -0,0 +1,109 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 033525824882ae4e8d9d12a74cef044d5fad8b30e7234634d83b8dec5460b57f + +name: safe-json +version: 0.1.0 +synopsis: Automatic JSON format versioning +description: This library aims to make the updating of JSON formats or contents, while keeping backward compatibility, as painless as possible. The way this is achieved is through versioning and defined migration functions to migrate older (or newer) versions to the one used. + . + The library mainly consists of two classes: + . + * @SafeJSON a@: Defines the version of @a@ and if (and how) it is migratable. + . + * @Migrate a@: Defines the data type (@MigrateFrom a@) that can be migrated to @a@ and how to migrate from that type. + . + Using these two classes, JSON serialized data types will stay parsable, even after format changes. + . + For a more in-depth explanation and examples, please see the README at +category: JSON +homepage: https://github.com/Vlix/safe-json#readme +bug-reports: https://github.com/Vlix/safe-json/issues +author: Felix Paulusma +maintainer: felix.paulusma@gmail.com +copyright: 2019 Felix Paulusma +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README + ChangeLog.md + +source-repository head + type: git + location: https://github.com/Vlix/safe-json + +library + exposed-modules: + Data.Aeson.Safe + Data.SafeJSON + Data.SafeJSON.Test + other-modules: + Data.SafeJSON.Instances + Data.SafeJSON.Internal + Paths_safe_json + hs-source-dirs: + src + default-extensions: OverloadedStrings + build-depends: + aeson >=1.4.1 && <1.5 + , base >=4.9 && <5 + , bytestring >=0.10.8.1 && <0.11 + , containers >=0.5.7.1 && <0.7 + , dlist >=0.8.0.3 && <0.9 + , hashable >=1.2.6.1 && <1.3 + , scientific >=0.3.5.2 && <0.4 + , tasty >=0.11.3 && <1.3 + , tasty-hunit >=0.9.2 && <0.11 + , tasty-quickcheck >=0.8.4 && <0.11 + , text >=1.2.3 && <1.3 + , time >=1.6.0.1 && <1.9 + , unordered-containers >=0.2.9 && <0.3 + , uuid-types >=1.0.3 && <1.1 + , vector >=0.12.0.1 && <0.13 + default-language: Haskell2010 + +test-suite safe-json-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Consistency.Migrations + Consistency.Primitives + ConsistencyTests + Instances + MigrationTests + PrimitiveTests + SafeAeson + Types + VersionNum + Paths_safe_json + hs-source-dirs: + test + default-extensions: OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.4.1 && <1.5 + , base >=4.9 && <5 + , bytestring >=0.10.8.1 && <0.11 + , containers >=0.5.7.1 && <0.7 + , dlist >=0.8.0.3 && <0.9 + , generic-arbitrary >=0.1.0 && <0.2 + , hashable >=1.2.6.1 && <1.3 + , quickcheck-instances >=0.3.16 && <0.4 + , safe-json >=0.1.0 && <0.2 + , scientific >=0.3.5.2 && <0.4 + , tasty + , tasty-hunit + , tasty-quickcheck + , temporary >=1.2.1.1 && <1.4 + , text >=1.2.3 && <1.3 + , time >=1.6.0.1 && <1.9 + , unordered-containers >=0.2.9 && <0.3 + , uuid >=1.3.13 && <1.4 + , uuid-types >=1.0.3 && <1.1 + , vector >=0.12.0.1 && <0.13 + default-language: Haskell2010 diff --git a/src/Data/Aeson/Safe.hs b/src/Data/Aeson/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Safe.hs @@ -0,0 +1,178 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} +{-| +Module : Data.Aeson.Safe +Copyright : (c) 2019 Felix Paulusma +License : MIT +Maintainer : felix.paulusma@gmail.com +Stability : experimental + +This module contains homonyms of the "Data.Aeson" library's +encoding and decoding functions that, instead, use +"Data.SafeJSON"'s conversions. +This way, switching from "Data.Aeson" to "Data.SafeJSON" is +very easy. After any "Data.Aeson" imports, just add @.Safe@. + +It also exports "Data.Aeson" itself for convenience, but still +hides 'parseJSON' and 'toJSON' so you will get errors if you +use them anywhere. That way you can explicitly decide where +to switch to 'safeFromJSON' or 'safeToJSON', or keep the +current "Data.Aeson" functions. +-} +module Data.Aeson.Safe ( + module Data.SafeJSON + , module Aeson + , decode + , decode' + , eitherDecode + , eitherDecode' + , encode + , encodeFile + + , decodeStrict + , decodeStrict' + , eitherDecodeStrict + , eitherDecodeStrict' + , decodeFileStrict + , decodeFileStrict' + , eitherDecodeFileStrict + , eitherDecodeFileStrict' + , encodeStrict + + , parseEither + , parseMaybe + ) where + + +import Data.Aeson as Aeson hiding ( + decode + , decode' + , decodeFileStrict + , decodeFileStrict' + , decodeStrict + , decodeStrict' + , eitherDecode + , eitherDecode' + , eitherDecodeFileStrict + , eitherDecodeFileStrict' + , eitherDecodeStrict + , eitherDecodeStrict' + , encode + , encodeFile + + , parseJSON + , toJSON + ) +import qualified Data.Aeson as A ( + decode + , decode' + , decodeFileStrict + , decodeFileStrict' + , decodeStrict + , decodeStrict' + , eitherDecode + , eitherDecode' + , eitherDecodeFileStrict + , eitherDecodeFileStrict' + , eitherDecodeStrict + , eitherDecodeStrict' + , encode + , encodeFile + ) +import Data.Aeson.Types +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.SafeJSON + + +-- These definitions might not be the most efficient way to +-- encode/decode JSON values (especially not as efficient as +-- Aeson itself), but that can be addressed later if needed. +-- +-- Aeson does the majority of the work encoding to and decoding +-- from 'ByteString's anyway. + +-- * Decoding and encoding of SafeJSON types + +-- ** Lazy ByteString variants + +-- | Try to decode a 'LBS.ByteString' to a 'SafeJSON' value. +decode :: SafeJSON a => LBS.ByteString -> Maybe a +decode lbs = A.decode lbs >>= parseMaybe safeFromJSON + +-- | Try to decode a 'LBS.ByteString' to a 'SafeJSON' value. +decode' :: SafeJSON a => LBS.ByteString -> Maybe a +decode' lbs = A.decode' lbs >>= parseMaybe safeFromJSON + +-- | Try to decode a 'LBS.ByteString' to a 'SafeJSON' value. +-- Produces an error message on failure. +eitherDecode :: SafeJSON a => LBS.ByteString -> Either String a +eitherDecode lbs = A.eitherDecode lbs >>= parseEither safeFromJSON + +-- | Try to decode a 'LBS.ByteString' to a 'SafeJSON' value. +-- Produces an error message on failure. +eitherDecode' :: SafeJSON a => LBS.ByteString -> Either String a +eitherDecode' lbs = A.eitherDecode' lbs >>= parseEither safeFromJSON + +-- | Encode a 'SafeJSON' value to a 'LBS.ByteString'. +encode :: SafeJSON a => a -> LBS.ByteString +encode = A.encode . safeToJSON + +------------------------------------------------------ +-- Strict variants +------------------------------------------------------ + +-- ** Strict ByteString variants + +-- | Try to decode a 'BS.ByteString' to a 'SafeJSON' value. +decodeStrict :: SafeJSON a => BS.ByteString -> Maybe a +decodeStrict lbs = A.decodeStrict lbs >>= parseMaybe safeFromJSON + +-- | Try to decode a 'BS.ByteString' to a 'SafeJSON' value. +decodeStrict' :: SafeJSON a => BS.ByteString -> Maybe a +decodeStrict' lbs = A.decodeStrict' lbs >>= parseMaybe safeFromJSON + +-- | Try to decode a 'BS.ByteString' to a 'SafeJSON' value. +-- Produces an error message on failure. +eitherDecodeStrict :: SafeJSON a => BS.ByteString -> Either String a +eitherDecodeStrict lbs = A.eitherDecodeStrict lbs >>= parseEither safeFromJSON + +-- | Try to decode a 'BS.ByteString' to a 'SafeJSON' value. +-- Produces an error message on failure. +eitherDecodeStrict' :: SafeJSON a => BS.ByteString -> Either String a +eitherDecodeStrict' lbs = A.eitherDecodeStrict' lbs >>= parseEither safeFromJSON + +-- | Same as 'encode', but also calls 'LBS.toStrict', for convenience. +encodeStrict :: SafeJSON a => a -> BS.ByteString +encodeStrict = LBS.toStrict . encode + +-- * Encoding to and decoding from files + +-- | Try to decode a file to a 'SafeJSON' value. +decodeFileStrict :: SafeJSON a => FilePath -> IO (Maybe a) +decodeFileStrict fp = do + mVal <- A.decodeFileStrict fp + return $ mVal >>= parseMaybe safeFromJSON + +-- | Try to decode a file to a 'SafeJSON' value. +decodeFileStrict' :: SafeJSON a => FilePath -> IO (Maybe a) +decodeFileStrict' fp = do + mVal <- A.decodeFileStrict' fp + return $ mVal >>= parseMaybe safeFromJSON + +-- | Try to decode a file to a 'SafeJSON' value. +-- Produces an error message on failure. +eitherDecodeFileStrict :: SafeJSON a => FilePath -> IO (Either String a) +eitherDecodeFileStrict fp = do + eVal <- A.eitherDecodeFileStrict fp + return $ eVal >>= parseEither safeFromJSON + +-- | Try to decode a file to a 'SafeJSON' value. +-- Produces an error message on failure. +eitherDecodeFileStrict' :: SafeJSON a => FilePath -> IO (Either String a) +eitherDecodeFileStrict' fp = do + eVal <- A.eitherDecodeFileStrict' fp + return $ eVal >>= parseEither safeFromJSON + +-- | Encode a 'SafeJSON' value to a file. +encodeFile :: SafeJSON a => FilePath -> a -> IO () +encodeFile fp = A.encodeFile fp . safeToJSON diff --git a/src/Data/SafeJSON.hs b/src/Data/SafeJSON.hs new file mode 100644 --- /dev/null +++ b/src/Data/SafeJSON.hs @@ -0,0 +1,92 @@ +{-| +Module : Data.SafeJSON.Instances +Copyright : (c) 2019 Felix Paulusma +License : MIT +Maintainer : felix.paulusma@gmail.com +Stability : experimental + +Please read the + +__[README on GitHub](https://github.com/Vlix/safe-json/blob/v0.1.0/README.md)__ + +for an extensive explanation of this library, why and how to use it, +and examples. +-} +module Data.SafeJSON + ( + -- * Conversion to/from versioned JSON + -- + -- | These functions are the workhorses of the library. + -- + -- As long as a type has a 'SafeJSON' instance and, if conversion + -- from other types is required, a 'Migrate' instance, these will + -- make sure to add and read version numbers, and handle migration. + safeToJSON + , safeFromJSON + -- * SafeJSON Class + -- + -- | This class, together with 'Migrate', is where the magic happens! + -- + -- Using the 'SafeJSON' class to define the form and expected + -- migration to a type, and defining 'Migrate' instances to describe + -- how to handle the conversion from older versions (or maybe a + -- newer version) to the type, you can be sure that your programs + -- will still parse the JSON of types it is expecting. + , SafeJSON(version, kind, safeTo, safeFrom, objectProfile, typeName) + -- *** Contained + , Contained + , contain + -- ** Version + -- + -- | All 'SafeJSON' instances have a 'version'. This version will be + -- attached to the JSON format and used to figure out which parser + -- (and as such, which type in the chain) should be used to parse + -- the given JSON. + , Version + , noVersion + -- ** Kind + -- + -- | All 'SafeJSON' instance have a declared 'kind', indicating if any + -- migration needs to happen when parsing using 'safeFromJSON'. + -- + -- * The Base kind (see 'base') is at the bottom of the chain and will + -- not be migrated to. They can optionally have no version tag by + -- defining: @'version' = 'noVersion'@. + -- /N.B./ 'base' /and/ 'extended_base' /are the only kinds that can/ + -- /be paired with/ 'noVersion'. + -- + -- * Extensions (see 'extension' and 'extended_extension') tell the + -- system that there exists at least one previous version of the data + -- type which should be migrated from if needed. + -- (This requires the data type to also have a @Migrate a@ instance) + -- + -- * Forward extensions (see 'extended_base' and 'extended_extension') + -- tell the system there exists at least one next version from which + -- the data type can be reverse-migrated. + -- (This requires the data type to also have a @Migrate (Reverse a)@ + -- instance) + , Kind + , base + , extension + , extended_base + , extended_extension + -- *** Showing the type + -- + -- | These helper functions can be used to easily define 'typeName'. + -- As long as the type being defined has a 'Typeable' instance. + , typeName0 + , typeName1 + , typeName2 + , typeName3 + , typeName4 + , typeName5 + -- ** Consistency + , Profile(..) + , ProfileVersions(..) + -- * Migration + , Migrate(..) + , Reverse(..) + ) where + +import Data.SafeJSON.Internal +import Data.SafeJSON.Instances() diff --git a/src/Data/SafeJSON/Instances.hs b/src/Data/SafeJSON/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/SafeJSON/Instances.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module : Data.SafeJSON.Instances +Copyright : (c) 2019 Felix Paulusma +License : MIT +Maintainer : felix.paulusma@gmail.com +Stability : experimental + +This module contains 'SafeJSON' instances for almost +all types that "Data.Aeson" has 'Data.Aeson.FromJSON' +and 'Data.Aeson.ToJSON' instances for. These instances +are all defined with 'noVersion' and 'base', since +these types should never get a version wrapper, should +use the existing "Data.Aeson" instances and do not extend +any other type. + +All these types are extendable if need be. Just use +any of these types in the definition of your 'Migrate' +instance. + +(e.g. @type MigrateFrom MyType = Int@) +-} +module Data.SafeJSON.Instances (SafeJSON(..)) where + + +import Control.Applicative (Const(..)) +import Data.Aeson (DotNetTime, FromJSONKey, ToJSONKey, Value(..), parseJSON, toJSON) +import Data.Aeson.Types (Parser) +import Data.Char (Char) +import Data.DList as DList (DList, fromList) +import Data.Fixed (Fixed, HasResolution) +import Data.Functor.Identity (Identity(..)) +import Data.Functor.Compose (Compose) -- FIXME: add SafeJSON Instances +import Data.Functor.Product (Product) -- FIXME: add SafeJSON Instances +import Data.Functor.Sum (Sum(..)) -- FIXME: add SafeJSON Instances +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM (HashMap, fromList, toList) +import qualified Data.HashSet as HS (HashSet, fromList, toList) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map (Map) +import Data.Monoid (Dual(..)) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio) +import Data.Scientific (Scientific) +import Data.Semigroup (First(..), Last(..), Max(..), Min(..)) +import Data.Sequence (Seq) +import qualified Data.Set as S (Set, fromList, toList) +import Data.Text as T (Text) +import Data.Text.Lazy as LT (Text) +import Data.Time +import Data.Tree (Tree) +import Data.UUID.Types (UUID) +import qualified Data.Vector as V +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import Data.Version as DV (Version) +import Data.Void (Void) +import Data.Word (Word8, Word16, Word32, Word64) +import Foreign.C.Types (CTime) +import Numeric.Natural (Natural) + +import Data.SafeJSON.Internal + + +-- ---------------------- -- +-- SafeJSON Instances -- +-- ---------------------- -- + +#define BASIC_NULLARY(T) \ +instance SafeJSON T where { version = noVersion } + +BASIC_NULLARY(Void) +BASIC_NULLARY(Bool) +BASIC_NULLARY(Ordering) +BASIC_NULLARY(()) +BASIC_NULLARY(Char) +BASIC_NULLARY(Float) +BASIC_NULLARY(Double) +BASIC_NULLARY(Int) +BASIC_NULLARY(Natural) +BASIC_NULLARY(Integer) +BASIC_NULLARY(Int8) +BASIC_NULLARY(Int16) +BASIC_NULLARY(Int32) +BASIC_NULLARY(Int64) +BASIC_NULLARY(Word) +BASIC_NULLARY(Word8) +BASIC_NULLARY(Word16) +BASIC_NULLARY(Word32) +BASIC_NULLARY(Word64) +BASIC_NULLARY(T.Text) +BASIC_NULLARY(LT.Text) +BASIC_NULLARY(DV.Version) +BASIC_NULLARY(Scientific) +BASIC_NULLARY(IntSet) +BASIC_NULLARY(UUID) +BASIC_NULLARY(Value) + +instance (SafeJSON a, Integral a) => SafeJSON (Ratio a) where + typeName = typeName1 + version = noVersion + +instance (HasResolution a) => SafeJSON (Fixed a) where + typeName = typeName1 + version = noVersion + +instance SafeJSON (Proxy a) where + typeName = typeName1 + version = noVersion + +instance {-# OVERLAPPING #-} SafeJSON String where + typeName _ = "String" + version = noVersion + + +-- --------------------------- -- +-- SafeJSON Time Instances -- +-- --------------------------- -- + +BASIC_NULLARY(CTime) +BASIC_NULLARY(ZonedTime) +BASIC_NULLARY(LocalTime) +BASIC_NULLARY(TimeOfDay) +BASIC_NULLARY(UTCTime) +BASIC_NULLARY(NominalDiffTime) +BASIC_NULLARY(DiffTime) +BASIC_NULLARY(Day) +BASIC_NULLARY(DotNetTime) + +-- ------------------------------------ -- +-- More involved SafeJSON instances -- +-- ------------------------------------ -- + +instance SafeJSON a => SafeJSON (Const a b) where + safeFrom val = contain $ Const <$> safeFromJSON val + safeTo (Const a) = contain $ safeToJSON a + typeName = typeName2 + version = noVersion + +instance SafeJSON a => SafeJSON (Maybe a) where + -- This follows the same 'Null' logic as the aeson library + safeFrom Null = contain $ pure (Nothing :: Maybe a) + safeFrom val = contain $ Just <$> safeFromJSON val + -- Nothing means do whatever Aeson thinks Nothing should be + safeTo Nothing = contain $ toJSON (Nothing :: Maybe a) + -- If there's something, keep it safe + safeTo (Just a) = contain $ safeToJSON a + typeName = typeName1 + version = noVersion + +instance (SafeJSON a, SafeJSON b) => SafeJSON (Either a b) where + safeFrom val = contain $ do + eVal <- parseJSON val + case eVal of + Left a -> Left <$> safeFromJSON a + Right b -> Right <$> safeFromJSON b + safeTo (Left a) = contain $ toJSON (Left $ safeToJSON a :: Either Value Void) + safeTo (Right b) = contain $ toJSON (Right $ safeToJSON b :: Either Void Value) + typeName = typeName2 + version = noVersion + +#define BASIC_UNARY(T) \ +instance SafeJSON a => SafeJSON (T a) where { \ + safeFrom val = contain $ T <$> safeFromJSON val; \ + safeTo (T a) = contain $ safeToJSON a; \ + typeName = typeName1; \ + version = noVersion } + +BASIC_UNARY(Identity) +BASIC_UNARY(First) +BASIC_UNARY(Last) +BASIC_UNARY(Min) +BASIC_UNARY(Max) +BASIC_UNARY(Dual) + +fromGenericVector :: (SafeJSON a, VG.Vector v a) => Value -> Contained (Parser (v a)) +fromGenericVector val = contain $ do + v <- parseJSON val + VG.convert <$> VG.mapM safeFromJSON (v :: V.Vector Value) + +toGenericVector :: (SafeJSON a, VG.Vector v a) => v a -> Contained Value +toGenericVector = contain . toJSON . fmap safeToJSON . VG.toList + +instance SafeJSON a => SafeJSON (V.Vector a) where + safeFrom = fromGenericVector + safeTo = toGenericVector + typeName = typeName1 + version = noVersion + +instance (SafeJSON a, VP.Prim a) => SafeJSON (VP.Vector a) where + safeFrom = fromGenericVector + safeTo = toGenericVector + typeName = typeName1 + version = noVersion + +instance (SafeJSON a, VS.Storable a) => SafeJSON (VS.Vector a) where + safeFrom = fromGenericVector + safeTo = toGenericVector + typeName = typeName1 + version = noVersion + +instance (SafeJSON a, VG.Vector VU.Vector a) => SafeJSON (VU.Vector a) where + safeFrom = fromGenericVector + safeTo = toGenericVector + typeName = typeName1 + version = noVersion + +-- | Lists and any other "container" are seen as only that: +-- a container for 'SafeJSON' values. +-- +-- "Containers" are implemented in such a way that when parsing +-- a collection of all migratable versions, the result will be +-- a list of that type where each element has been migrated as +-- appropriate. +instance {-# OVERLAPPABLE #-} SafeJSON a => SafeJSON [a] where + safeFrom val = contain $ do + vs <- parseJSON val + mapM safeFromJSON vs + safeTo as = contain . toJSON $ safeToJSON <$> as + typeName = typeName1 + version = noVersion + +#define BASIC_UNARY_FUNCTOR(T) \ +instance SafeJSON a => SafeJSON (T a) where { \ + safeFrom val = contain $ do { \ + vs <- parseJSON val; \ + mapM safeFromJSON vs }; \ + safeTo as = contain . toJSON $ safeToJSON <$> as; \ + typeName = typeName1; \ + version = noVersion } + +BASIC_UNARY_FUNCTOR(IntMap) +BASIC_UNARY_FUNCTOR(NonEmpty) +BASIC_UNARY_FUNCTOR(Seq) +BASIC_UNARY_FUNCTOR(Tree) + +instance (SafeJSON a) => SafeJSON (DList a) where + safeFrom val = contain $ do + vs <- parseJSON val + DList.fromList <$> mapM safeFromJSON vs + safeTo as = contain . toJSON $ safeToJSON <$> as + typeName = typeName1 + version = noVersion + +instance (SafeJSON a, Ord a) => SafeJSON (S.Set a) where + safeFrom val = contain $ do + vs <- parseJSON val + S.fromList <$> safeFromJSON vs + safeTo as = contain . toJSON $ safeToJSON <$> S.toList as + typeName = typeName1 + version = noVersion + +instance (Ord k, FromJSONKey k, ToJSONKey k, SafeJSON a) => SafeJSON (Map k a) where + safeFrom val = contain $ do + vs <- parseJSON val + mapM safeFromJSON vs + safeTo as = contain . toJSON $ safeToJSON <$> as + typeName = typeName2 + version = noVersion + +instance (SafeJSON a, Eq a, Hashable a) => SafeJSON (HS.HashSet a) where + safeFrom val = contain $ do + vs <- parseJSON val + HS.fromList <$> safeFromJSON vs + safeTo as = contain . toJSON $ safeToJSON <$> HS.toList as + typeName = typeName1 + version = noVersion + +instance (Hashable a, FromJSONKey a, ToJSONKey a, Eq a, SafeJSON b) => SafeJSON (HM.HashMap a b) where + safeFrom val = contain $ do + vs <- parseJSON val + fmap HM.fromList . mapM (mapM safeFromJSON) $ HM.toList vs + safeTo as = contain . toJSON $ safeToJSON <$> as + typeName = typeName2 + version = noVersion + +instance (SafeJSON a, SafeJSON b) => SafeJSON (a, b) where + safeFrom x = contain $ do + (a',b') <- parseJSON x + a <- safeFromJSON a' + b <- safeFromJSON b' + return (a,b) + safeTo (a,b) = contain $ toJSON (safeToJSON a, safeToJSON b) + typeName = typeName2 + version = noVersion + +instance (SafeJSON a, SafeJSON b, SafeJSON c) => SafeJSON (a, b, c) where + safeFrom x = contain $ do + (a',b',c') <- parseJSON x + a <- safeFromJSON a' + b <- safeFromJSON b' + c <- safeFromJSON c' + return (a,b,c) + safeTo (a,b,c) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c) + typeName = typeName3 + version = noVersion + +instance (SafeJSON a, SafeJSON b, SafeJSON c, SafeJSON d) => SafeJSON (a, b, c, d) where + safeFrom x = contain $ do + (a',b',c',d') <- parseJSON x + a <- safeFromJSON a' + b <- safeFromJSON b' + c <- safeFromJSON c' + d <- safeFromJSON d' + return (a,b,c,d) + safeTo (a,b,c,d) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c, safeToJSON d) + typeName = typeName4 + version = noVersion + +instance (SafeJSON a, SafeJSON b, SafeJSON c, SafeJSON d, SafeJSON e) => SafeJSON (a, b, c, d, e) where + safeFrom x = contain $ do + (a',b',c',d',e') <- parseJSON x + a <- safeFromJSON a' + b <- safeFromJSON b' + c <- safeFromJSON c' + d <- safeFromJSON d' + e <- safeFromJSON e' + return (a,b,c,d,e) + safeTo (a,b,c,d,e) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c, safeToJSON d, safeToJSON e) + typeName = typeName5 + version = noVersion diff --git a/src/Data/SafeJSON/Internal.hs b/src/Data/SafeJSON/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/SafeJSON/Internal.hs @@ -0,0 +1,608 @@ +-- This module heavily relies on code borrowed from the "safecopy" +-- library by David Himmelstrup and Felipe Lessa, found on +-- "https://github.com/acid-state/safecopy" +-- +-- Though it has gone through extensive refactoring because of +-- desired behaviour being different from the safecopy library +-- and the fact that this library works with JSON, instead of +-- byte serialization. +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-| +Module : Data.SafeJSON.Internal +Copyright : (c) 2019 Felix Paulusma +License : MIT +Maintainer : felix.paulusma@gmail.com +Stability : experimental + +This module contains all "under-the-hood" functions +and types. "Data.SafeJSON" exports everything for the +outward-facing API. +-} +module Data.SafeJSON.Internal where + + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.Fail (MonadFail) +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.HashMap.Strict as HM (insert, size) +import Data.Int +import qualified Data.List as List (intercalate, lookup) +import Data.Maybe (fromMaybe, isJust, isNothing) +#if MIN_VERSION_base(4,11,0) +#else +import Data.Monoid ((<>)) +#endif +import Data.Proxy +import qualified Data.Set as S +import Data.Text (Text) +import Data.Typeable (Typeable, typeRep) +import Test.Tasty.QuickCheck (Arbitrary(..), shrinkIntegral) + + +-- | A type that can be converted from and to JSON with versioning baked +-- in, using 'Migrate' to automate migration between versions, reducing +-- headaches when the need arrises to modify JSON formats while old +-- formats can't simply be disregarded. +class (ToJSON a, FromJSON a) => SafeJSON a where + -- | The version of the type. + -- + -- Only used as a key so it __must be unique__ (this is checked at run-time) + -- + -- Version numbering __doesn't have to be sequential or continuous__. + -- + -- /The default version is 0 (zero)./ + version :: Version a + version = 0 + + -- | The kind specifies how versions are dealt with. By default, + -- values are tagged with version 0 and don't have any + -- previous versions. + -- + -- /The default kind is/ 'base' + kind :: Kind a + kind = Base + + -- | This method defines how a value should be serialized without worrying + -- about adding the version. The default implementation uses 'toJSON', but + -- can be modified if need be. + -- + -- This function cannot be used directly. Use 'safeToJSON', instead. + safeTo :: a -> Contained Value + safeTo = contain . toJSON + + -- | This method defines how a value should be parsed without also worrying + -- about writing out the version tag. The default implementation uses 'parseJSON', + -- but can be modified if need be. + -- + -- This function cannot be used directly. Use 'safeFromJSON', instead. + safeFrom :: Value -> Contained (Parser a) + safeFrom = contain . parseJSON + + -- | The name of the type. This is used in error message strings and the + -- 'Profile' report. + -- + -- Doesn't have to be defined if your type is 'Data.Typeable.Typeable'. The default + -- implementation is 'typeName0'. (cf. 'typeName1', 'typeName2', etc.) + typeName :: Proxy a -> String + default typeName :: Typeable a => Proxy a -> String + typeName = typeName0 + + -- Internal function that should not be overrided. + -- @Consistent@ if the version history is consistent + -- (i.e. there are no duplicate version numbers) and + -- the chain of migrations is valid. + -- + -- This function is in the typeclass so that this + -- information is calculated only once during the program + -- lifetime, instead of everytime 'safeFrom' or 'safeTo' is used. + internalConsistency :: Consistency a + internalConsistency = computeConsistency Proxy + + -- | Version profile. + -- + -- Shows the current version of the type and all supported + -- versions it can migrate from. + objectProfile :: Profile a + objectProfile = mkProfile Proxy + + {-# MINIMAL #-} + +-- | This instance is needed to handle the migration between +-- older and newer versions. +-- +-- Note that, where @(Migrate a)@ migrates from the previous +-- version to the type @a@, @(Migrate (Reverse a))@ migrates +-- from the future version to the type @a@. +-- +-- === __Example__ +-- +-- __Two types that can migrate to each other.__ +-- +-- (Don't forget to give @OldType@ one of the @extended@ 'kind's, +-- and @NewType@ one of the @extension@ kinds.) +-- +-- @ +-- instance 'Migrate' NewType where +-- type 'MigrateFrom' NewType = OldType +-- 'migrate' OldType = NewType +-- +-- instance 'Migrate' (Reverse OldType) where +-- type 'MigrateFrom' (Reverse OldType) = NewType +-- 'migrate' NewType = Reverse OldType +-- @ +class SafeJSON (MigrateFrom a) => Migrate a where + -- | The type from which will be migrated to type @a@ + type MigrateFrom a + -- | The migration from the previous version to the + -- current type @a@. OR, in case of a @(Reverse a)@, + -- the migration from the future version back to + -- the current type @a@ + migrate :: MigrateFrom a -> a + + +-- | This is an inpenetrable container. A security measure +-- used to ensure 'safeFrom' and 'safeTo' are never used +-- directly. Instead, always use 'safeFromJSON' and +-- 'safeToJSON'. +newtype Contained a = Contained {unsafeUnpack :: a} + +-- | Used when defining 'safeFrom' or 'safeTo'. +contain :: a -> Contained a +contain = Contained + + +-- | A simple numeric version id. +-- +-- 'Version' has a 'Num' instance and should be +-- declared using integer literals: @version = 2@ +newtype Version a = Version {unVersion :: Maybe Int64} +-- Is it better to use 'Int32'? +-- Maybe 'Int64' is too big for JSON? + deriving (Eq) + +-- | This is used for types that don't have +-- a version tag. +-- +-- This is used for primitive values that are tagged with +-- a version number, like @Int@, @Text@, @[a]@, etc. +-- +-- But also when implementing 'SafeJSON' after the fact, +-- when a format is already in use, but you still want to +-- be able to 'migrate' from it to a newer type or format. +-- +-- /N.B./ @version = noVersion@ /is distinctively different/ +-- /from/ @version = 0@/, which will add a version tag with/ +-- /the number 0 (zero), whereas/ 'noVersion' /will not add a/ +-- /version tag./ +noVersion :: Version a +noVersion = Version Nothing + +instance Show (Version a) where + show (Version mi) = "Version " ++ showV mi + +liftV :: Integer -> (Int64 -> Int64 -> Int64) -> Maybe Int64 -> Maybe Int64 -> Maybe Int64 +liftV _ _ Nothing Nothing = Nothing +liftV i f ma mb = Just $ toZ ma `f` toZ mb + where toZ = fromMaybe $ fromInteger i + +-- 'Version Nothing' is handled as if it's mempty... mostly. +-- | It is strongly discouraged to use any methods other +-- than 'fromInteger' of 'Version' 's 'Num' instance. +instance Num (Version a) where + Version ma + Version mb = Version $ liftV 0 (+) ma mb + Version ma - Version mb = Version $ liftV 0 (-) ma mb + Version ma * Version mb = Version $ liftV 1 (*) ma mb + negate (Version ma) = Version $ negate <$> ma + abs (Version ma) = Version $ abs <$> ma + signum (Version ma) = Version $ signum <$> ma + fromInteger i = Version $ Just $ fromInteger i + +-- | This instance explicitly doesn't consider 'noVersion', since it +-- is an exception in almost every sense. +instance Arbitrary (Version a) where + arbitrary = Version . Just <$> arbitrary + shrink (Version Nothing) = [] + shrink (Version (Just a)) = Version . Just <$> shrinkIntegral a + +castVersion :: Version a -> Version b +castVersion (Version i) = Version i + +-- | This is a wrapper type used migrating backwards in the chain of compatible types. +-- +-- This is useful when running updates in production where new-format JSON will be +-- received by old-format expecting programs. +newtype Reverse a = Reverse { unReverse :: a } + +-- | The 'kind' of a 'SafeJSON' type determines how it can be migrated to. +data Kind a where + Base :: Kind a + Extends :: Migrate a => Proxy (MigrateFrom a) -> Kind a + Extended :: Migrate (Reverse a) => Kind a -> Kind a + +-- | Used to define 'kind'. +-- @Base@ types do not extend any type. +base :: Kind a +base = Base + +-- | Used to define 'kind'. +-- Extends a previous version. +extension :: (SafeJSON a, Migrate a) => Kind a +extension = Extends Proxy + +-- | Used to define 'kind'. +-- Types that are 'extended_base', are extended by a +-- future version and as such can migrate backward from +-- that future version. (cf. 'extended_extension', 'base') +extended_base :: (SafeJSON a, Migrate (Reverse a)) => Kind a +extended_base = Extended base + +-- | Used to define 'kind'. +-- Types that are 'extended_extension' are extended +-- by a future version and as such can migrate from +-- that future version, but they also extend a previous +-- version. (cf. 'extended_base', 'extension') +extended_extension :: (SafeJSON a, Migrate a, Migrate (Reverse a)) => Kind a +extended_extension = Extended extension + +-- The '!' and '~' used in these set fields are chosen for their +-- low probability of showing up naturally in JSON objects one +-- would normally find or construct. + +versionField :: Text +versionField = "!v" + +dataVersionField :: Text +dataVersionField = "~v" + +dataField :: Text +dataField = "~d" + +-- | Use this exactly how you would use 'toJSON' from "Data.Aeson". +-- Though most use cases will probably use one of the 'Data.Aeson.Safe.encode' +-- functions from "Data.Aeson.Safe". +-- +-- 'safeToJSON' will add a version tag to the 'Data.Aeson.Value' created. +-- If the 'Data.Aeson.Value' resulting from 'safeTo' (by default the same as 'toJSON') +-- is an @Object@, an extra field with the version number will be added. +-- +-- > Example value: +-- > {"type":"test", "data":true} +-- > +-- > Resulting object: +-- > {"!v": 1, "type":"test", "data":true} +-- +-- If the resulting 'Value' is not an @Object@, it will be wrapped +-- in one, with a version field: +-- +-- > Example value: +-- > "arbitrary string" +-- > +-- > Resulting object: +-- > {"~v": 1, "~d": "arbitrary string"} +-- +-- __This function does not check consistency of the 'SafeJSON' instances.__ +-- __It is advised to always 'Data.SafeJSON.Test.testConsistency' for all__ +-- __your instances in a production setting.__ +safeToJSON :: forall a. SafeJSON a => a -> Value +safeToJSON a = case thisKind of + Base | i == Nothing -> tojson + Extended Base | i == Nothing -> tojson + _ -> case tojson of + Object o -> Object $ HM.insert versionField (toJSON i) o + other -> object + [ dataVersionField .= i + , dataField .= other + ] + where tojson = unsafeUnpack $ safeTo a + Version i = version :: Version a + thisKind = kind :: Kind a + +-- The consistency is checked on first parse, after that +-- there is no overhead. +-- | Use this exactly how you would use 'parseJSON' from "Data.Aeson". +-- Though most use cases will probably use one of the 'Data.Aeson.Safe.decode' +-- functions from "Data.Aeson.Safe". +-- +-- 'safeFromJSON' tries to find the version number in the JSON +-- 'Value' provided, find the appropriate parser and migrate the +-- parsed result back to the requested type using 'Migrate' +-- instances. +-- +-- If there is no version number (that means this can also happen with +-- completely unrelated JSON messages), and there is a 'SafeJSON' +-- instance in the chain that has 'version' defined as 'noVersion', +-- it will try to parse that type. +-- +-- __N.B. If the consistency of the 'SafeJSON' instance in__ +-- __question is faulty, this will always fail.__ +safeFromJSON :: forall a. SafeJSON a => Value -> Parser a +safeFromJSON origVal = checkConsistency p $ \vs -> do + let hasVNil = noVersionPresent vs + case origKind of + Base | i == Nothing -> unsafeUnpack $ safeFrom origVal + Extended k | i == Nothing -> extendedCase hasVNil k + _ -> regularCase hasVNil + where Version i = version :: Version a + origKind = kind :: Kind a + p = Proxy :: Proxy a + safejsonErr s = fail $ "safejson: " ++ s + regularCase hasVNil = case origVal of + Object o -> do + (mVal, v) <- tryIt o + let val = fromMaybe origVal mVal + withVersion v val origKind + _ -> withoutVersion <|> safejsonErr ("unparsable JSON value (not an object): " ++ typeName p) + where withoutVersion = withVersion noVersion origVal origKind + tryIt o + | hasVNil = firstTry o <|> secondTry o <|> pure (Nothing, noVersion) + | otherwise = firstTry o <|> secondTry o + + -- This only runs if the SafeJSON being tried has 'kind' of 'extended_*' + -- and the version is 'noVersion'. + -- (internalConsistency checks that it should be an 'Extended Base' since it has 'noVersion') + -- We check the newer version first, since it's better to try to find the + -- version, if there is one, to guarantee the right parser. + extendedCase :: Migrate (Reverse a) => Bool -> Kind a -> Parser a + extendedCase hasVNil k = case k of { Base -> go; _ -> regularCase hasVNil } + where go = case origVal of + Object o -> tryNew o <|> tryOrig + _ -> tryOrig + tryNew o = do + (mVal, v) <- firstTry o <|> secondTry o + let forwardKind = getForwardKind k + forwardVersion = castVersion v + val = fromMaybe origVal mVal + getForwardParser = withVersion forwardVersion val forwardKind + unReverse . migrate <$> getForwardParser + tryOrig = unsafeUnpack $ safeFrom origVal + + withVersion :: forall b. SafeJSON b => Version b -> Value -> Kind b -> Parser b + withVersion v val k = either fail id eResult + where eResult = constructParserFromVersion val v k + + firstTry o = do + v <- o .: versionField + return (Nothing, Version $ Just v) + secondTry o = do + v <- o .: dataVersionField + bd <- o .: dataField + -- This is an extra counter measure against false parsing. + -- The simple data object should contain exactly the + -- (~v) and (~d) fields + when (HM.size o /= 2) $ fail $ "malformed simple data (" ++ show (Version $ Just v) ++ ")" + return (Just bd, Version $ Just v) + +-- This takes the version number found (or Nothing) and tries find the type in +-- the chain that has that version number. It will attempt to go one type up +-- (try 'Migrate (Reverse a)' once) and after that down the chain. +constructParserFromVersion :: SafeJSON a => Value -> Version a -> Kind a -> Either String (Parser a) +constructParserFromVersion val origVersion origKind = + worker False origVersion origKind + where + worker :: forall b. SafeJSON b => Bool -> Version b -> Kind b -> Either String (Parser b) + worker fwd thisVersion thisKind + | version == thisVersion = return $ unsafeUnpack $ safeFrom val + | otherwise = case thisKind of + Base -> Left versionNotFound + Extends p -> fmap migrate <$> worker fwd (castVersion thisVersion) (kindFromProxy p) + Extended k -> do + -- Technically, the forward and backward parsing could be + -- infinite, as long as all 'Migrate' instances are defined. + -- The problem is that chains can fork if, after going forward, + -- the kind of that forward type is used to continue, since + -- there's no guarantee that the migrations will continue backward + -- down the previous chain. + -- + -- TODO: Somehow restrict Migrate instances in such a way that, if defined: + -- > MigrateFrom (Reverse b) = a + -- > THEN ALSO + -- > MigrateFrom a = b + -- + -- @ + -- v1 Base v1' Base v1'' Ext_Base + -- | | /\ + -- | | | + -- \/ \/ \/ + -- v2 Exs -> v3 Ext_Exs -> v4 Exs + -- @ + -- + -- I've opted for the following approach: + -- "Try forward once, if the version is wrong, go down your own chain" + -- + -- IDEA: Maybe it could be written in such a way that the backward type + -- (Base or Extends) in the Extended data constructor is passed along on + -- up the chain until the top is reached, after which the run downward + -- starts with Extends, or the run ends in case it was a Base type. + let forwardParser :: Either String (Parser b) + forwardParser = do + if castVersion thisVersion == versionFromProxy reverseProxy + then Right $ unReverse . migrate <$> unsafeUnpack (safeFrom val) + else previousParser + + previousParser :: Either String (Parser b) + previousParser = worker True thisVersion k + -- If we've already looked ahead, or if it's 'noVersion', we go back. + -- ('noVersion' means we need to find the 'Base', that's always backwards) + if fwd || thisVersion == noVersion + then previousParser + else either (const previousParser) Right forwardParser + where versionNotFound = "Cannot find parser associated with: " <> show origVersion + reverseProxy :: Proxy (MigrateFrom (Reverse b)) + reverseProxy = Proxy + +-- | Type name string representation of a __nullary__ type constructor. +typeName0 :: Typeable a => Proxy a -> String +typeName0 = show . typeRep + +-- | Type name string representation of a __unary__ type constructor. +typeName1 :: forall t a. Typeable t => Proxy (t a) -> String +typeName1 _ = show $ typeRep (Proxy :: Proxy t) + +-- | Type name string representation of a __binary__ type constructor. +typeName2 :: forall t a b. Typeable t => Proxy (t a b) -> String +typeName2 _ = show $ typeRep (Proxy :: Proxy t) + +-- | Type name string representation of a __ternary__ type constructor. +typeName3 :: forall t a b c. Typeable t => Proxy (t a b c) -> String +typeName3 _ = show $ typeRep (Proxy :: Proxy t) + +-- | Type name string representation of a __4-ary__ type constructor. +typeName4 :: forall t a b c d. Typeable t => Proxy (t a b c d) -> String +typeName4 _ = show $ typeRep (Proxy :: Proxy t) + +-- | Type name string representation of a __5-ary__ type constructor. +typeName5 :: forall t a b c d e. Typeable t => Proxy (t a b c d e) -> String +typeName5 _ = show $ typeRep (Proxy :: Proxy t) + + +-- | Profile of the internal consistency of a 'SafeJSON' instance. +-- +-- /N.B. 'noVersion' shows as/ @null@ /instead of a number./ +data Profile a = InvalidProfile String -- ^ There is something wrong with versioning + | Profile ProfileVersions -- ^ Profile of consistent versions + deriving (Eq) + +-- | Version profile of a consistent 'SafeJSON' instance. +data ProfileVersions = ProfileVersions { + profileCurrentVersion :: Maybe Int64, -- ^ Version of the type checked for consistency. + profileSupportedVersions :: [(Maybe Int64, String)] -- ^ All versions in the chain with their type names. + } deriving (Eq) + +noVersionPresent :: ProfileVersions -> Bool +noVersionPresent (ProfileVersions c vs) = + isNothing c || isJust (Nothing `List.lookup` vs) + +showV :: Maybe Int64 -> String +showV Nothing = "null" +showV (Just i) = show i + +showVs :: [(Maybe Int64, String)] -> String +showVs = List.intercalate ", " . fmap go + where go (mi, s) = mconcat ["(", showV mi, ", ", s, ")"] + +-- | @Version Nothing@ shows as @null@ +instance Show ProfileVersions where + show (ProfileVersions cur sup) = mconcat + [ "version ", showV cur, ": [" + , showVs sup, "]" + ] + +instance Typeable a => Show (Profile a) where + show (InvalidProfile s) = "InvalidProfile: " <> s + show (Profile pv) = + let p = Proxy :: Proxy a + in mconcat [ "Profile for \"", typeName0 p + , "\" (", show pv, ")" + ] + +-- | Easy way to get a printable failure/success report +-- of the internal consistency of a SafeJSON instance. +mkProfile :: forall a. SafeJSON a => Proxy a -> Profile a +mkProfile p = case computeConsistency p of + NotConsistent t -> InvalidProfile t + Consistent -> Profile $ ProfileVersions { + profileCurrentVersion = unVersion (version @a), + profileSupportedVersions = availableVersions p + } + +data Consistency a = Consistent + | NotConsistent String + +checkConsistency :: (SafeJSON a, MonadFail m) => Proxy a -> (ProfileVersions -> m b) -> m b +checkConsistency p m = + case mkProfile p of + InvalidProfile s -> fail s + Profile vs -> m vs + +computeConsistency :: forall a. SafeJSON a => Proxy a -> Consistency a +computeConsistency p +-- This checks the chain of versions to not clash or loop, +-- and it verifies only 'Base' or 'Extended Base' kinds can +-- have 'noVersion' + | isObviouslyConsistent (kind @a) = Consistent + | Just s <- invalidChain p = NotConsistent s + | otherwise = Consistent +{-# INLINE computeConsistency #-} + +isObviouslyConsistent :: Kind a -> Bool +isObviouslyConsistent Base = True +isObviouslyConsistent _ = False + +availableVersions :: forall a. SafeJSON a => Proxy a -> [(Maybe Int64, String)] +availableVersions _ = + worker False (kind @a) + where + worker :: forall b. SafeJSON b => Bool -> Kind b -> [(Maybe Int64, String)] + worker fwd thisKind = case thisKind of + Base -> [tup] + Extends p' -> tup : worker fwd (kindFromProxy p') + Extended k | not fwd -> worker True (getForwardKind k) + Extended k -> worker True k + + where Version v = version @b + name = typeName (Proxy @b) + tup = (v, name) + +-- TODO: Have this output a custom type to differentiate between bad outcomes. +-- That way the tests can be more reliable. (Did they catch what they were +-- supposed to catch?) +invalidChain :: forall a. SafeJSON a => Proxy a -> Maybe String +invalidChain _ = + worker mempty mempty (kind @a) + where + -- Version set Version set with type name Kind Maybe error + worker :: forall b. SafeJSON b => S.Set (Maybe Int64) -> S.Set (Maybe Int64, String) -> Kind b -> Maybe String + worker vs vSs k + | i `S.member` vs = Just $ mconcat + [ "Double occurence of version number '", showV i + , "' (type: ", typeName p + , "). Looping instances if the previous combination of type and version number are found here: " + , showVs $ S.toList vSs + ] + | otherwise = case k of + Base -> Nothing + Extends{} | i == Nothing -> Just $ mconcat + [ typeName p, " has defined 'version = noVersion', " + , " but it's 'kind' definition is not 'base' or 'extended_base'" + ] + Extends a_proxy -> worker newVSet newVsSet (kindFromProxy a_proxy) + Extended a_kind -> let v@(Version i') = versionFromKind $ getForwardKind a_kind + tup = (i', typeName (proxyFromVersion v)) + in worker (S.insert i' vs) (S.insert tup vSs) a_kind + where Version i = version @b + p = Proxy @b + newVSet = S.insert i vs + newVsSet = S.insert (i, typeName p) vSs + + +---------------------------------------------------------- +-- Conversion functions +---------------------------------------------------------- + +proxyFromVersion :: Version a -> Proxy a +proxyFromVersion _ = Proxy + +kindFromProxy :: SafeJSON a => Proxy a -> Kind a +kindFromProxy _ = kind + +versionFromProxy :: SafeJSON a => Proxy a -> Version a +versionFromProxy _ = version + +versionFromKind :: SafeJSON a => Kind a -> Version a +versionFromKind _ = version + +getForwardKind :: Migrate (Reverse a) => Kind a -> Kind (MigrateFrom (Reverse a)) +getForwardKind _ = kind diff --git a/src/Data/SafeJSON/Test.hs b/src/Data/SafeJSON/Test.hs new file mode 100644 --- /dev/null +++ b/src/Data/SafeJSON/Test.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-| +Module : Data.SafeJSON.Test +Copyright : (c) 2019 Felix Paulusma +License : MIT +Maintainer : felix.paulusma@gmail.com +Stability : experimental + +This module contains some functions to use for testing +'SafeJSON' and 'Migrate' instances. +-} +module Data.SafeJSON.Test ( + -- * Consistency checks + -- + -- | It is advised to always run 'testConsistency' (or + -- 'testConsistency'') for all your types that have + -- a 'SafeJSON' instance. + -- + -- __Note that any type that fails this test will also__ + -- __fail any 'safeFromJSON' parsing!__ + + -- ** Using TypeApplications + testConsistency + -- ** Using a Proxy argument + , testConsistency' + -- * Unit tests + -- + -- ** Migration tests + -- + -- | These tests can be used to verify the implemented + -- 'migrate' function acts as expected. + , testMigration + , testReverseMigration + -- *** Synonyms + , (<=?) + , (>=?) + -- ** Round trip tests + -- + -- | These tests can be used to verify that round trips are + -- consistent. Either directly ('testRoundTrip'), through + -- a forward migration ('migrateRoundTrip') or a reversed + -- backward migration ('migrateReverseRoundTrip'). + , testRoundTrip + , migrateRoundTrip + , migrateReverseRoundTrip + -- * Property tests + -- + -- | Useful if your types also have 'Arbitrary' instances. + + -- *** Constraint synonyms for readability + -- + , TestMigrate + , TestReverseMigrate + -- ** Using TypeApplications + , testRoundTripProp + , migrateRoundTripProp + , migrateReverseRoundTripProp + -- ** Using a Proxy argument + , testRoundTripProp' + , migrateRoundTripProp' + , migrateReverseRoundTripProp' + -- * Re-export for convenience + , Proxy(..) + ) where + + +import Data.Aeson.Types (parseEither) +import Data.Proxy +import Data.SafeJSON.Internal +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (Assertion, assertEqual) +import Test.Tasty.QuickCheck (Arbitrary, testProperty) + + +-- | Useful in test suites. Will fail if anything in the +-- chain of your types is inconsistent. +-- +-- === __Example usage:__ +-- +-- > testConsistency @MyType +testConsistency :: forall a. SafeJSON a => Assertion +testConsistency = checkConsistency p $ \_ -> return () + where p = Proxy :: Proxy a + +-- | Useful in test suites. Will fail if anything in the +-- chain of your types is inconsistent. +testConsistency' :: forall a. SafeJSON a => Proxy a -> Assertion +testConsistency' = flip checkConsistency $ \_ -> return () + +-- | Tests that the following holds: +-- +-- prop> Just a == parseMaybe (safeFromJSON . safeToJSON) a +testRoundTrip :: (Show a, Eq a, SafeJSON a) => a -> Assertion +testRoundTrip a = "To JSON and back not consistent" `assertEqual` Right a $ + parseEither (safeFromJSON . safeToJSON) a + +-- | Tests that the following holds __for all @a@__: +-- +-- prop> Just a == parseMaybe (safeFromJSON . safeToJSON) a +testRoundTripProp' :: forall a. (Eq a, Show a, Arbitrary a, SafeJSON a) => Proxy a -> String -> TestTree +testRoundTripProp' _ s = testProperty s $ \a -> + Right (a :: a) == parseEither (safeFromJSON . safeToJSON) a + +-- | Tests that the following holds for all @a@: +-- +-- prop> Just a == parseMaybe (safeFromJSON . safeToJSON) a +-- +-- === __Example usage:__ +-- +-- > testRoundTripProp @MyType s +testRoundTripProp :: forall a. (Eq a, Show a, Arbitrary a, SafeJSON a) => String -> TestTree +testRoundTripProp s = testProperty s $ \a -> + Right (a :: a) == parseEither (safeFromJSON . safeToJSON) a + +-- | Migration test. Mostly useful as regression test. +-- +-- First argument is the older type which should turn into +-- the second argument after migrating using 'migrate'. +-- +-- prop> Just (migrate a) == parseMaybe (safeFromJSON . safeToJSON) a +testMigration :: (Show a, Eq a, Migrate a) => MigrateFrom a -> a -> Assertion +testMigration = assertEqual "Unexpected result of SafeJSON migration" . migrate + +-- | Similar to 'testMigration', but using @Migrate (Reverse a)@. +-- +-- The first argument here is the newer type, which will be migrated back +-- to the expected second argument (older type). +-- +-- prop> Just (unReverse $ migrate a) == parseMaybe (safeFromJSON . safeToJSON) a +testReverseMigration :: (Show a, Eq a, Migrate (Reverse a)) => MigrateFrom (Reverse a) -> a -> Assertion +testReverseMigration = assertEqual "Unexpected result of SafeJSON migration" . unReverse . migrate + +infix 1 >=?, <=? +-- | Operator synonymous with 'testMigration' +(<=?) :: (Show a, Eq a, Migrate a) => MigrateFrom a -> a -> Assertion +(<=?) = testMigration + +-- | Operator synonymous with 'testReverseMigration' +(>=?) :: (Show a, Eq a, Migrate (Reverse a)) => MigrateFrom (Reverse a) -> a -> Assertion +(>=?) = testReverseMigration + +-- | This test verifies that direct migration, and migration +-- through encoding and decoding to the newer type, is equivalent. +migrateRoundTrip :: forall a. (Eq a, Show a, SafeJSON a, Migrate a) => MigrateFrom a -> Assertion +migrateRoundTrip oldType = "Unexpected result of decoding encoded older type" `assertEqual` Right (migrate oldType :: a) $ + parseEither (safeFromJSON . safeToJSON) oldType + +-- | Similar to 'migrateRoundTrip', but tests the migration from a newer type +-- to the older type, in case of a @Migrate (Reverse a)@ instance +migrateReverseRoundTrip :: forall a. (Eq a, Show a, SafeJSON a, Migrate (Reverse a)) => MigrateFrom (Reverse a) -> Assertion +migrateReverseRoundTrip newType = "Unexpected result of decoding encoded newer type" `assertEqual` Right (unReverse $ migrate newType :: a) $ + parseEither (safeFromJSON . safeToJSON) newType + +-- | Constraints for migrating from a previous version +type TestMigrate a b = + ( Eq a + , Show (MigrateFrom a) + , Arbitrary (MigrateFrom a) + , SafeJSON a + , SafeJSON (MigrateFrom a) + , Migrate a + , MigrateFrom a ~ b + ) + +-- | This test verifies that direct migration, and migration +-- through encoding and decoding to the newer type, is equivalent +-- __for all @a@__. +-- +-- prop> Just (migrate a) == parseMaybe (safeFromJSON . safeToJSON) a +migrateRoundTripProp' :: forall a b. TestMigrate a b => Proxy (a,b) -> String -> TestTree +migrateRoundTripProp' _ s = testProperty s $ \a -> + Right (migrate a :: a) == parseEither (safeFromJSON . safeToJSON) a + +-- | This test verifies that direct migration, and migration +-- through encoding and decoding to the newer type, is equivalent +-- __for all @a@__. +-- +-- prop> Just (migrate a) == parseMaybe (safeFromJSON . safeToJSON) a +-- +-- === __Example usage:__ +-- +-- > migrateRoundTripProp @NewType @OldType s +migrateRoundTripProp :: forall a b. TestMigrate a b => String -> TestTree +migrateRoundTripProp s = testProperty s $ \a -> + Right (migrate a :: a) == parseEither (safeFromJSON . safeToJSON) a + +-- | Constraints for migrating from a future version +type TestReverseMigrate a b = + ( Eq a + , Show (MigrateFrom (Reverse a)) + , Arbitrary (MigrateFrom (Reverse a)) + , SafeJSON a + , Migrate (Reverse a) + , MigrateFrom (Reverse a) ~ b + ) + +-- | Similar to 'migrateRoundTripProp, but tests the migration from a newer type +-- to the older type, in case of a @Migrate (Reverse a)@ instance. +-- +-- prop> Just (unReverse $ migrate a) == parseMaybe (safeFromJSON . safeToJSON) a +migrateReverseRoundTripProp' :: forall a b. TestReverseMigrate a b => Proxy (a,b) -> String -> TestTree +migrateReverseRoundTripProp' _ s = testProperty s $ \a -> + Right (unReverse $ migrate a :: a) == parseEither (safeFromJSON . safeToJSON) a + +-- | Similar to 'migrateRoundTripProp', but tests the migration from a newer type +-- to the older type, in case of a @Migrate (Reverse a)@ instance. +-- +-- prop> Just (unReverse $ migrate a) == parseMaybe (safeFromJSON . safeToJSON) a +-- +-- === __Example usage:__ +-- +-- /Please also note the reversing of the type applications./ +-- +-- > migrateReverseRoundTripProp @OldType @NewType s +migrateReverseRoundTripProp :: forall a b. TestReverseMigrate a b => String -> TestTree +migrateReverseRoundTripProp s = testProperty s $ \a -> + Right (unReverse $ migrate a :: a) == parseEither (safeFromJSON . safeToJSON) a diff --git a/test/Consistency/Migrations.hs b/test/Consistency/Migrations.hs new file mode 100644 --- /dev/null +++ b/test/Consistency/Migrations.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Consistency.Migrations where + + +import Data.Aeson +import Data.Text (Text, pack) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Data.SafeJSON +import Data.SafeJSON.Test + + +-- 'OldType' and 'NewType' should be well-defined for these +-- tests to succeed. +migrationConsistency :: TestTree +migrationConsistency = testGroup "Migration Consistency" + [ oldNewTypeChecks + , roundTripTest + , reverseRoundTripTest + , roundTripTestProp + , reverseRoundTripTestProp + ] + + +oldNewTypeChecks :: TestTree +oldNewTypeChecks = testGroup "Consistent Old-/NewType" + [ testCase "OldType is consistent" $ testConsistency @OldType + , testCase "NewType is consistent" $ testConsistency @NewType + , testRoundTripProp @OldType "Round trip (OldType)" + , testRoundTripProp @NewType "Round trip (NewType)" + ] + +roundTripTest :: TestTree +roundTripTest = testCase "Round trip function test" $ do + let oldType = OldType "test" 1 + testRoundTrip oldType + migrateRoundTrip @NewType oldType + +reverseRoundTripTest :: TestTree +reverseRoundTripTest = testCase "Reverse round trip function test" $ do + let newType = NewType [1,2,3] False + testRoundTrip newType + migrateReverseRoundTrip @OldType newType + +roundTripTestProp :: TestTree +roundTripTestProp = migrateRoundTripProp @NewType @OldType "Round trip property function test" + +reverseRoundTripTestProp :: TestTree +reverseRoundTripTestProp = migrateReverseRoundTripProp @OldType @NewType "Reverse round trip property function test" + + +---------------------------------------------------------- +-- Well-defined types +---------------------------------------------------------- + +data OldType = OldType Text Int + deriving (Eq, Show) + +instance FromJSON OldType where + parseJSON = withObject "OldType" $ \o -> do + i <- o .: "old_type_int" + t <- o .: "old_type_text" + return $ OldType t i + +instance ToJSON OldType where + toJSON (OldType t i) = object + [ "old_type_int" .= i + , "old_type_text" .= t + ] + +instance SafeJSON OldType where + version = noVersion + kind = extended_base + +instance Arbitrary OldType where + arbitrary = OldType . pack <$> arbitrary <*> arbitrary + + +data NewType = NewType { + newInts :: [Int], + hasText :: Bool +} deriving (Eq, Show) + +instance FromJSON NewType where + parseJSON = withObject "NewType" $ \o -> do + newInts <- o .: "new_type_ints" + hasText <- o .: "new_type_bool" + return NewType{..} + +instance ToJSON NewType where + toJSON (NewType is b) = object + [ "new_type_ints" .= is + , "new_type_bool" .= b + ] + +instance SafeJSON NewType where + version = 1 + kind = extension + +instance Migrate NewType where + type MigrateFrom NewType = OldType + migrate (OldType t i) = NewType [i] $ if t == mempty then False else True + +instance Arbitrary NewType where + arbitrary = NewType <$> arbitrary <*> arbitrary + + +instance Migrate (Reverse OldType) where + type MigrateFrom (Reverse OldType) = NewType + migrate (NewType is b) = Reverse $ OldType t i + where i = case is of + [] -> 0 + (x:_) -> x + t = if b then "yes" else "" diff --git a/test/Consistency/Primitives.hs b/test/Consistency/Primitives.hs new file mode 100644 --- /dev/null +++ b/test/Consistency/Primitives.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TypeApplications #-} +module Consistency.Primitives where + + +import Control.Applicative (Const) +import Data.Aeson (DotNetTime, Value) +import Data.Char (Char) +import Data.DList (DList) +import Data.Fixed (E12, Fixed) +import Data.Functor.Identity (Identity) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Monoid (Dual) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio) +import Data.Scientific (Scientific) +import Data.Semigroup (First, Last, Max, Min) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Text as T (Text) +import Data.Text.Lazy as LT (Text) +import Data.Time +import Data.Tree (Tree) +import Data.UUID.Types (UUID) +import qualified Data.Vector as V +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import Data.Version as DV (Version) +import Data.Word (Word8, Word16, Word32, Word64) +import Foreign.C.Types (CTime) +import Numeric.Natural (Natural) + +import Test.Tasty + +import Data.SafeJSON() +import Data.SafeJSON.Test (testRoundTripProp) +import Instances() + + +primitiveConsistency :: TestTree +primitiveConsistency = testGroup "Primitives conversions" + [ testRoundTripProp @Bool "Bool" + , testRoundTripProp @Ordering "Ordering" + , testRoundTripProp @() "()" + , testRoundTripProp @Char "Char" + , testRoundTripProp @Float "Float" + , testRoundTripProp @Double "Double" + , testRoundTripProp @Int "Int" + , testRoundTripProp @Natural "Natural" + , testRoundTripProp @Integer "Integer" + , testRoundTripProp @Int8 "Int8" + , testRoundTripProp @Int16 "Int16" + , testRoundTripProp @Int32 "Int32" + , testRoundTripProp @Int64 "Int64" + , testRoundTripProp @Word "Word" + , testRoundTripProp @Word8 "Word8" + , testRoundTripProp @Word16 "Word16" + , testRoundTripProp @Word32 "Word32" + , testRoundTripProp @Word64 "Word64" + , testRoundTripProp @T.Text "T.Text" + , testRoundTripProp @LT.Text "LT.Text" + , testRoundTripProp @DV.Version "DV.Version" + , testRoundTripProp @Scientific "Scientific" + , testRoundTripProp @IntSet "IntSet" + , testRoundTripProp @UUID "UUID" + , testRoundTripProp @CTime "CTime" + -- , testRoundTripProp @ZonedTime "ZonedTime" -- Apparently, there's a reason there's no Eq instance + , testRoundTripProp @LocalTime "LocalTime" + , testRoundTripProp @TimeOfDay "TimeOfDay" + , testRoundTripProp @UTCTime "UTCTime" + , testRoundTripProp @NominalDiffTime"NominalDiffTime" + , testRoundTripProp @DiffTime "DiffTime" + , testRoundTripProp @Day "Day" + , testRoundTripProp @DotNetTime "DotNetTime" + , testRoundTripProp @Value "Value" + + , testRoundTripProp @(Ratio Int) "Ratio" + , testRoundTripProp @(Fixed E12) "Fixed" + , testRoundTripProp @(Proxy ()) "Proxy" + , testRoundTripProp @(Identity T.Text) "Identity" + , testRoundTripProp @(First T.Text) "First" + , testRoundTripProp @(Last T.Text) "Last" + , testRoundTripProp @(Min T.Text) "Min" + , testRoundTripProp @(Max T.Text) "Max" + , testRoundTripProp @(Dual T.Text) "Dual" + , testRoundTripProp @([Int]) "[]" + , testRoundTripProp @(IntMap Bool) "IntMap" + , testRoundTripProp @(NonEmpty Int) "NonEmpty" + , testRoundTripProp @(Seq T.Text) "Seq" + , testRoundTripProp @(Tree T.Text) "Tree" + , testRoundTripProp @(Const T.Text ()) "Const" + , testRoundTripProp @(Maybe T.Text) "Maybe" + , testRoundTripProp @(Maybe T.Text) "Maybe2" + , testRoundTripProp @(Either T.Text Bool) "Either" + , testRoundTripProp @(Either T.Text Bool) "Either2" + , testRoundTripProp @(DList Int) "DList" + , testRoundTripProp @(V.Vector Int) "V.Vector" + , testRoundTripProp @(VS.Vector Int) "VS.Vector" + , testRoundTripProp @(VP.Vector Int) "VP.Vector" + , testRoundTripProp @(VU.Vector Int) "VU.Vector" + , testRoundTripProp @(Set Int) "Set" + , testRoundTripProp @(Map T.Text Int) "Map" + , testRoundTripProp @(HashSet Int) "HashSet" + , testRoundTripProp @(HashMap T.Text Int) "HashMap" + , testRoundTripProp @(Int, Bool) "Tuple2" + , testRoundTripProp @(Int, Bool, T.Text) "Tuple3" + , testRoundTripProp @(Int, Bool, T.Text, [Int]) "Tuple4" + , testRoundTripProp @(Int, Bool, T.Text, [Int], Double) "Tuple5" + ] diff --git a/test/ConsistencyTests.hs b/test/ConsistencyTests.hs new file mode 100644 --- /dev/null +++ b/test/ConsistencyTests.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module ConsistencyTests where + + +import Control.Exception (SomeException, catch) +import Control.Monad (when) +import Data.Aeson +import Data.Text (Text) +import Test.Tasty +import Test.Tasty.HUnit + +import Consistency.Primitives (primitiveConsistency) +import Consistency.Migrations (migrationConsistency) +import Data.SafeJSON +import Data.SafeJSON.Test (testConsistency, testRoundTrip) + + +-- FIXME: Better testing would be possible with specific Exceptions +-- raised by testConsistency. (Or 'invalidChain' should give custom +-- types instead of String, so mkProfile/computeConsistency can output +-- a result to match on) + +consistencyTests :: TestTree +consistencyTests = testGroup "Consistency" + [ catchLoops + , catchBadInstance + , dontCatchGoodType + , dontCatchGoodType2 + , dontCatchGoodType3 + , dontCatchGoodType4 + , catchBadKind + , catchBadKind2 + , catchBadKind3 + , catchBadKind4 + , catchBadKind5 + , catchBadKind6 + , primitiveConsistency + , migrationConsistency + ] + + +shouldFail :: String -> String -> IO () -> TestTree +shouldFail s err io = testCase s $ do + b <- tryIt `catch` success + when b $ assertFailure err + where tryIt = io >> return True + success :: SomeException -> IO Bool + success _ = return False + + +----------------------- +-- LOOPING INSTANCES -- +----------------------- + +-- | This is important, since if this wouldn't be caught +-- any invocation of 'checkConsistency' (like in safeFromJSON) +-- will lock up and eat up all your memory. +catchLoops :: TestTree +catchLoops = shouldFail + "Catch looping instances (checkConsistency)" + "Didn't catch looping instance" + $ testConsistency @LoopType1 + + +data LoopType1 = LoopType1 deriving (Eq, Show) + +data LoopType2 = LoopType2 + +instance SafeJSON LoopType1 where + version = 0 + kind = extension + +instance SafeJSON LoopType2 where + version = 1 + kind = extension + +instance ToJSON LoopType1 where + toJSON _ = Null + +instance ToJSON LoopType2 where + toJSON _ = Null + +instance FromJSON LoopType1 where + parseJSON Null = pure LoopType1 + parseJSON _ = fail "uhhh wat" + +instance FromJSON LoopType2 where + parseJSON Null = pure LoopType2 + parseJSON _ = fail "uhhh wat" + +instance Migrate LoopType1 where + type MigrateFrom LoopType1 = LoopType2 + migrate _ = LoopType1 + +instance Migrate LoopType2 where + type MigrateFrom LoopType2 = LoopType1 + migrate _ = LoopType2 + + +------------------------- +-- Catch bad instances -- +------------------------- + +-- | Just for redundancy +catchBadInstance :: TestTree +catchBadInstance = shouldFail + "Catch bad JSON instance" + "Allowed bad instance conversion" + $ testRoundTrip $ BadJSON 2 + + +data BadJSON = BadJSON Int deriving (Eq, Show) + +instance FromJSON BadJSON where + parseJSON = withText "BadJSON" $ \case + "bad" -> pure $ BadJSON 1 + _ -> fail "wat" + +instance ToJSON BadJSON where + toJSON (BadJSON 2) = String "bad" + toJSON _ = String "wat" + +instance SafeJSON BadJSON where + version = noVersion + + +--------------------- +-- Catch bad chain -- +--------------------- + +dontCatchGoodType :: TestTree +dontCatchGoodType = testCase "DuplicateType is consistent" $ + testConsistency @DuplicateType + +dontCatchGoodType2 :: TestTree +dontCatchGoodType2 = testCase "DuplicateType0 is consistent" $ + testConsistency @DuplicateType0 + +dontCatchGoodType3 :: TestTree +dontCatchGoodType3 = testCase "DuplicateTypeX is consistent" $ + testConsistency @DuplicateTypeX + +dontCatchGoodType4 :: TestTree +dontCatchGoodType4 = testCase "DummyDuplicate is consistent" $ + testConsistency @DummyDuplicate + +catchBadKind :: TestTree +catchBadKind = shouldFail + "Catch bad SafeJSON instances (duplicate version)" + "Allowed instances with duplicate versions" + $ testConsistency @DuplicateType1 + +catchBadKind2 :: TestTree +catchBadKind2 = shouldFail + "Catch bad SafeJSON instance (noVersion + extension)" + "Allowed 'noVersion' with non-(extended_)base 'kind'" + $ testConsistency @DuplicateType2 + +catchBadKind3 :: TestTree +catchBadKind3 = shouldFail + "Catch bad SafeJSON instance (noVersion + extended_extension)" + "Allowed 'noVersion' with non-(extended_)base 'kind'" + $ testConsistency @DuplicateType3 + +catchBadKind4 :: TestTree +catchBadKind4 = shouldFail + "Catch bad SafeJSON instance (duplicate future version)" + "Allowed future type with same version" + $ testConsistency @DuplicateType4 + +-- Kind of redundant because of 'catchBadKind', but hey... +catchBadKind5 :: TestTree +catchBadKind5 = shouldFail + "Catch bad SafeJSON instance (duplicate past version)" + "Allowed past type with same version" + $ testConsistency @DuplicateType5 + +catchBadKind6 :: TestTree +catchBadKind6 = shouldFail + "Catch bad SafeJSON instance (duplicate versions in chain)" + "Allowed past types with same version (this type's version not source of collision)" + $ testConsistency @DuplicateType6 + +-------------------------------------------------------------- +-- Conflicting version numbering / bad kinds +-------------------------------------------------------------- + +#define JSON(TYPE,VERSION,KIND) \ +data TYPE = TYPE Text; \ +instance FromJSON TYPE where { \ + parseJSON = withText "TYPE" $ pure . TYPE }; \ +instance ToJSON TYPE where { \ + toJSON (TYPE t) = String t }; \ +instance SafeJSON TYPE where { \ + version = VERSION; kind = KIND } + +#define MIGRATE(TYPE,OLDTYPE) \ +instance Migrate TYPE where { \ + type MigrateFrom TYPE = OLDTYPE; \ + migrate (OLDTYPE t) = TYPE t } + +#define REVERSE(TYPE,NEWTYPE) \ +instance Migrate (Reverse TYPE) where { \ + type MigrateFrom (Reverse TYPE) = NEWTYPE; \ + migrate (NEWTYPE t) = Reverse $ TYPE t } + +-- Basic type/instance, consistent +JSON(DuplicateType,noVersion,base) + +-- Basic type/instance, consistent +JSON(DuplicateType0,1,base) + +-- Extended type/instance, consistent +JSON(DuplicateTypeX,0,extended_base) +REVERSE(DuplicateTypeX,DummyDuplicate) + +-- This is just here so DuplicateTypeX has +-- something to 'MigrateFrom (Reverse a)' +JSON(DummyDuplicate,1,extension) +MIGRATE(DummyDuplicate,DuplicateTypeX) + +-- Extending type/instance, inconsistent (duplicate version number) +JSON(DuplicateType1,1,extension) +MIGRATE(DuplicateType1,DuplicateType0) + +-- Extending type/instance, inconsistent (noVersion + extension) +JSON(DuplicateType2,noVersion,extension) +MIGRATE(DuplicateType2,DuplicateType0) + +-- Extending type/instance, inconsistent (noVersion + extended_extension) +JSON(DuplicateType3,noVersion,extended_extension) +MIGRATE(DuplicateType3,DuplicateType0) +REVERSE(DuplicateType3,DummyDuplicate2) + +-- This is just here so DuplicateType3 has something to 'MigrateFrom (Reverse a)' +JSON(DummyDuplicate2,2,extension) +MIGRATE(DummyDuplicate2,DuplicateType3) + +-- Extended type/instance, inconsistent (future type has duplicate version number) +JSON(DuplicateType4,9,extended_base) +REVERSE(DuplicateType4,DuplicateType5) + +-- Extended type/instance, inconsistent (past type has duplicate version number) +JSON(DuplicateType5,9,extended_extension) +MIGRATE(DuplicateType5,DuplicateType4) +REVERSE(DuplicateType5,DuplicateType6) + +-- Extending type/instance, inconsistent (older types have duplicate version numbers) +JSON(DuplicateType6,10,extension) +MIGRATE(DuplicateType6,DuplicateType5) diff --git a/test/Instances.hs b/test/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Instances.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Instances ( + DotNetTime() + , DList() + , VP.Vector() + , Value() + ) where + + +import Data.Aeson +import Data.DList (DList, fromList, toList) +import Data.Int (Int64) +import Data.Time (NominalDiffTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Vector.Primitive as VP + +import Test.Tasty.QuickCheck (Arbitrary(..), oneof, resize) +import Test.QuickCheck.Arbitrary.Generic +import Test.QuickCheck.Instances() + +instance Arbitrary DotNetTime where + arbitrary = do + diff <- arbitrary + -- DotNetTime is only accurate to the millisecond + let floored = (/ 1000) + . fromIntegral + . (floor :: NominalDiffTime -> Int64) + $ (diff :: NominalDiffTime) * 1000 + return $ DotNetTime $ posixSecondsToUTCTime floored + shrink = fmap DotNetTime . shrink . fromDotNetTime + +instance Arbitrary a => Arbitrary (DList a) where + arbitrary = fromList <$> arbitrary + shrink = fmap fromList . shrink . toList + +instance (Arbitrary a, VP.Prim a) => Arbitrary (VP.Vector a) where + arbitrary = VP.fromList <$> arbitrary + shrink = fmap VP.fromList . shrink . VP.toList + +instance Arbitrary Value where + arbitrary = oneof + [ resize 5 $ Object <$> arbitrary + , resize 5 $ Array <$> arbitrary + , String <$> arbitrary + , Number <$> arbitrary + , Bool <$> arbitrary + , pure Null + ] + shrink = genericShrink + +-- | This is here just to test 'Set' in 'parseCollection' +instance Ord Value where + Null `compare` Null = EQ + Null `compare` _ = LT + _ `compare` Null = GT + a `compare` b + | Bool a' <- a, Bool b' <- b = a' `compare` b' + | Number a' <- a, Number b' <- b = a' `compare` b' + | String a' <- a, String b' <- b = a' `compare` b' + | Array a' <- a, Array b' <- b = a' `compare` b' + | Object a' <- a, Object b' <- b = a' `compare` b' + Bool{} `compare` _ = LT + Number{} `compare` Bool{} = GT + Number{} `compare` _ = LT + String{} `compare` Bool{} = GT + String{} `compare` Number{} = GT + String{} `compare` _ = LT + Array{} `compare` Object{} = LT + _ `compare` _ = GT diff --git a/test/MigrationTests.hs b/test/MigrationTests.hs new file mode 100644 --- /dev/null +++ b/test/MigrationTests.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +module MigrationTests where + + +import Control.Applicative (Const) +import Control.Exception (try) +import Control.Monad (forM) +import Data.Aeson hiding (eitherDecodeFileStrict) +import Data.Aeson as A (decodeFileStrict) +import Data.Aeson.Types (parseEither) +import Data.DList (DList) +import Data.Functor.Identity (Identity) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.IntMap as IntMap (IntMap, fromList) +import Data.List.NonEmpty (NonEmpty) +import Data.Map as Map (Map, fromList) +import Data.Maybe (fromJust) +import Data.Monoid (Dual) +import Data.Proxy +import Data.Semigroup (First, Last, Max, Min) +import Data.Set (Set) +import Data.Sequence (Seq) +import Data.Text (Text, pack) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.UUID as UUID +import qualified Data.Vector as V +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Data.Aeson.Safe (eitherDecodeFileStrict) +import Data.SafeJSON +import Data.SafeJSON.Test +import Instances() +import Types + + +migrationTests :: TestTree +migrationTests = testGroup "Migrations" + [ versionedPrimRoundTrip + + -- Migrating + , testSafeParse "vNil-> v1" "Couldn't parse v1 from vNil" "noversion" $ Version1 "12345" + + , testSafeParse "vNil-> v2" "Couldn't parse v2 from vNil" "noversion" $ Version2 ["12345"] + , testSafeParse "v1 -> v2" "Couldn't parse v2 from v1" "version1" $ Version2 ["success"] + + , testSafeParse "vNil-> v3" "Couldn't parse v3 from vNil" "noversion" $ Version3 ["12345"] False + , testSafeParse "v1 -> v3" "Couldn't parse v3 from v1" "version1" $ Version3 ["success"] False + , testSafeParse "v2 -> v3" "Couldn't parse v3 from v2" "version2" $ Version3 ["success!","or","is","it?!"] False + + , testSafeParse "vNil-> v4" "Couldn't parse v4 from vNil" "noversion" $ Version4 ["12345"] Nothing + , testSafeParse "v1 -> v4" "Couldn't parse v4 from v1" "version1" $ Version4 ["success"] Nothing + , testSafeParse "v2 -> v4" "Couldn't parse v4 from v2" "version2" $ Version4 ["success!","or","is","it?!"] Nothing + , testSafeParse "v3 -> v4" "Couldn't parse v4 from v3" "version3" $ Version4 ["success!","or","is","it?!"] (Just $ posixSecondsToUTCTime 0) + + -- Reverse migrating + , testSafeParse "v1 -> v0" "Couldn't parse v0 from v1" "version1" $ Version0 "success" + , testSafeParse "v2 -> v1" "Couldn't parse v1 from v2" "version2" $ Version1 "success!, or, is, it?!" + , testSafeParse "v4 -> v3" "Couldn't parse v3 from v4" "version4" $ Version3 ["success!","or","is","it?!"] True + , testSafeParse "v4-2-> v3" "Couldn't parse v3 from v4-2" "version4-2" $ Version3 ["one","two","three"] False + + -- Should not migrate + , testSafeNoParse @NoVersion "v2 -> vNil" "Shouldn't parse vNil from v2" "version2" vNilError + , testSafeNoParse @NoVersion "v3 -> vNil" "Shouldn't parse vNil from v3" "version3" vNilError + , testSafeNoParse @NoVersion "v4 -> vNil" "Shouldn't parse vNil from v4" "version4" vNilError + , testSafeNoParse @NoVersion "v4-2-> vNil" "Shouldn't parse vNil from v4" "version4-2" vNilError + + , testSafeNoParse @Version1 "v3 -> v1" "Shouldn't parse v1 from v3" "version3" $ noParserError "Version 3" + , testSafeNoParse @Version1 "v4 -> v1" "Shouldn't parse v1 from v4" "version4" $ noParserError "Version 4" + , testSafeNoParse @Version1 "v4-2-> v1" "Shouldn't parse v1 from v4-2" "version4-2" $ noParserError "Version 4" + + , testSafeNoParse @Version2 "v4 -> v2" "Shouldn't parse v2 from v4" "version4" $ noParserError "Version 4" + , testSafeNoParse @Version2 "v4-2-> v2" "Shouldn't parse v2 from v4-2" "version4-2" $ noParserError "Version 4" + + -- Other + , testSafeParse "simple versioning" "Couldn't parse simple data v1 from UUID" "simpleversion" $ SimpleVersion1 UUID.nil "" + , testSafeNoParse @BadVersion "bad simple" "Shouldn't parse from bad format" "badsimpleversion" $ EE "Error in $: malformed simple data (Version 8)" + + -- Container parsing + , parseCollection @[] @Version4 "[v4]" allVersioned singleList + , parseCollection @NonEmpty @Version4 "NonEmpty v4" allVersioned singleList + , parseCollection @DList @Version4 "DList v4" allVersioned singleList + , parseCollection @V.Vector @Version4 "V.Vector v4" allVersioned singleList + , parseCollection @IntMap @Version4 "IntMap v4" allVersioned $ toJSON . IntMap.fromList . zip [1..] . fmap snd + , parseCollection @(Map Text) @Version4 "Map v4" allVersioned objectList + , parseCollection @(HashMap Text) @Version4 "HashMap v4" allVersioned objectList + , parseCollection @Set @Version4 "Set v4" allVersioned singleList + , parseCollection @HashSet @Version4 "HashSet v4" allVersioned singleList + , parseCollection @Seq @Version4 "Seq v4" allVersioned singleList + + , parseCollection @Maybe @Version4 "Maybe v4" allVersioned single + , parseCollection @Identity @Version4 "Identity v4" allVersioned single + , parseCollection @(Const Version4) @Version4 "Const v4" allVersioned single + , parseCollection @First @Version4 "First v4" allVersioned single + , parseCollection @Last @Version4 "Last v4" allVersioned single + , parseCollection @Min @Version4 "Min v4" allVersioned single + , parseCollection @Max @Version4 "Max v4" allVersioned single + , parseCollection @Dual @Version4 "Dual v4" allVersioned single + + , parseCollection @((,) Version4) @Version4 "(v4,v4)" allVersioned $ toJSON . mkTup2 . fmap snd + , parseCollection @((,,) Version4 Version4) @Version4 "(v4,v4,v4)" allVersioned $ toJSON . mkTup3 . fmap snd + , parseCollection @((,,,) Version4 Version4 Version4) @Version4 "(v4,v4,v4,v4)" allVersioned $ toJSON . mkTup4 . fmap snd + , parseCollection @((,,,,) Version4 Version4 Version4 Version4) @Version4 "(v4,v4,v4,v4,v4)" allVersioned $ toJSON . mkTup5 . fmap snd + + , parseCollection @[] @Version3 "[v3]" allVersioned singleList + , parseCollection @[] @Version1 "[v1]" ["noversion","version1","version2"] singleList + , parseCollectionFail @[] @NoVersion "[vNil] [FAIL]" allVersioned singleList + , parseCollectionFail @[] @Version1 "[v1] [FAIL]" allVersioned singleList + , parseCollectionFail @[] @Version2 "[v2] [FAIL]" allVersioned singleList + ] + +singleList :: ToJSON b => [(a,b)] -> Value +singleList = toJSON . fmap snd + +objectList :: (Ord a, ToJSONKey a, ToJSON b) => [(a,b)] -> Value +objectList = toJSON . Map.fromList + +single :: ToJSON b => [(a,b)] -> Value +single = toJSON . snd . mkSing + +mkSing :: [a] -> a +mkSing (x:_) = x +mkTup2 :: [a] -> (a,a) +mkTup3 :: [a] -> (a,a,a) +mkTup4 :: [a] -> (a,a,a,a) +mkTup5 :: [a] -> (a,a,a,a,a) +mkTup2 (x:y:_) = (x,y) +mkTup3 (x:y:z:_) = (x,y,z) +mkTup4 (x:y:z:a:_) = (x,y,z,a) +mkTup5 (x:y:z:a:b:_) = (x,y,z,a,b) + +---------------------------------------------------------- +-- Versioned primitive round trip +---------------------------------------------------------- + +versionedPrimRoundTrip :: TestTree +versionedPrimRoundTrip = testRoundTripProp @VersionedPrim "Round trip (VersionedPrim)" + +newtype VersionedPrim = VersionedPrim { unVersionedPrim :: Text } deriving (Eq, Show) + +instance FromJSON VersionedPrim where parseJSON = withText "VersionedPrim" $ pure . VersionedPrim +instance ToJSON VersionedPrim where toJSON = String . unVersionedPrim +instance SafeJSON VersionedPrim where version = 2 +instance Arbitrary VersionedPrim where arbitrary = VersionedPrim . pack <$> arbitrary + + +---------------------------------------------------------- +-- Migration through versions +---------------------------------------------------------- + +newtype ExpectedError = EE String deriving (Eq, Show) + +vNilError :: ExpectedError +vNilError = EE "Error in $: key \"int\" not present" + +noParserError :: String -> ExpectedError +noParserError = EE . mappend "Error in $: Cannot find parser associated with: " + +jsonPath :: FilePath +jsonPath = "test/json/" + +testSafeParse :: (Eq a, Show a, SafeJSON a) => String -> String -> FilePath -> a -> TestTree +testSafeParse s a fp x = testCase s $ do + eVal <- eitherDecodeFileStrict $ jsonPath ++ fp ++ ".json" + case eVal of + Left err -> assertFailure err + Right val -> assertEqual a x val + +testSafeNoParse :: forall a. SafeJSON a => String -> String -> FilePath -> ExpectedError -> TestTree +testSafeNoParse s a fp (EE ee) = testCase (s ++ " [FAIL]") $ do + eVal <- eitherDecodeFileStrict $ jsonPath ++ fp ++ ".json" + case eVal :: Either String a of + Left err -> assertEqual a ee err + Right{} -> assertFailure $ fp ++ ": should not have parsed a " ++ typeName (Proxy @a) + + +---------------------------------------------------------- +-- Migration through collections +---------------------------------------------------------- + +allVersioned :: [String] +allVersioned = ["noversion","version1","version2","version3","version4"] + +parseCollection' :: forall f a. + ( SafeJSON a + , SafeJSON (f a) + ) + => (IO () -> IO ()) -> String -> [String] -> ([(Text,Value)] -> Value) -> TestTree +parseCollection' io s files f = testCase s $ io $ do + let fp x = jsonPath ++ x ++ ".json" + addFile x mA = (,) (pack x) <$> mA + mLs <- forM files $ \file -> addFile file <$> A.decodeFileStrict (fp file) + let ls = fromJust <$> mLs :: [(Text, Value)] + eVal = parseEither safeFromJSON $ f ls :: Either String (f a) + case eVal of + Right{} -> return () + Left err -> assertFailure $ mconcat + ["Could not parse collection of different versions (", typeName (Proxy :: Proxy a), "): ", err] + +parseCollection :: forall f a. + ( SafeJSON a + , SafeJSON (f a) + ) + => String -> [String] -> ([(Text,Value)] -> Value) -> TestTree +parseCollection = parseCollection' @f @a id + +parseCollectionFail :: forall f a. + ( SafeJSON a + , SafeJSON (f a) + ) + => String -> [String] -> ([(Text,Value)] -> Value) -> TestTree +parseCollectionFail = parseCollection' @f @a go + where go :: IO () -> IO () + go io = try io >>= \case + Left e -> return () `const` (e :: HUnitFailure) + Right{} -> assertFailure "Should have failed" diff --git a/test/PrimitiveTests.hs b/test/PrimitiveTests.hs new file mode 100644 --- /dev/null +++ b/test/PrimitiveTests.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module PrimitiveTests where + + +import Control.Applicative (Const) +import Data.Aeson (DotNetTime, Value, (.:)) +import qualified Data.Aeson as A +import Data.Aeson.Types (parseEither) +import Data.Char (Char) +import Data.DList (DList) +import Data.Fixed (E12, Fixed) +import Data.Functor.Identity (Identity) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Monoid (Dual) +import Data.Proxy (Proxy) +import Data.Ratio (Ratio) +import Data.Scientific (Scientific) +import Data.Semigroup (First, Last, Max, Min) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Text as T (Text, unpack) +import Data.Text.Lazy as LT (Text) +import Data.Time +import Data.Tree (Tree) +import Data.UUID.Types (UUID) +import qualified Data.Vector as V +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import Data.Version as DV (Version) +import Data.Word (Word8, Word16, Word32, Word64) +import Foreign.C.Types (CTime) +import Numeric.Natural (Natural) + +import Test.Tasty +import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) +import Test.Tasty.QuickCheck (Arbitrary, testProperty) + +import Data.SafeJSON +import Instances() + + +primitiveTests :: TestTree +primitiveTests = testGroup "Primitives" + [ regularParsing + , toJSONEquivalence + , fromJSONEquivalence + ] + + +parseValueAnd :: forall a. SafeJSON a => T.Text -> (a -> IO ()) -> TestTree +parseValueAnd t f = testCase (T.unpack t) $ do + mVal <- A.decodeFileStrict "test/json/primitives.json" + maybe + (assertFailure "couldn't read file") + (either fail f . parseEither go) + mVal + where go = A.withObject "test" $ \o -> do + o .: t >>= safeFromJSON + +parseValue :: forall a. SafeJSON a => T.Text -> TestTree +parseValue t = parseValueAnd t (const $ return () :: a -> IO ()) + +fromJSONTest :: forall a. (SafeJSON a, Eq a, Show a) => T.Text -> TestTree +fromJSONTest t = parseValueAnd t $ \val -> do + let a = (parseEither A.parseJSON val :: Either String a) + b = parseEither safeFromJSON val + assertEqual "SafeJSON not equivalent to FromJSON" a b + +toJSONTest :: forall a. (SafeJSON a, Arbitrary a, Show a) => String -> TestTree +toJSONTest s = testProperty s $ \a -> A.toJSON a == safeToJSON (a :: a) + + +regularParsing :: TestTree +regularParsing = testGroup "Parsing from JSON" + [ parseValue @Bool "Bool" + , parseValue @Ordering "Ordering" + , parseValue @() "Unit" + , parseValue @Char "Char" + , parseValue @Float "Float" + , parseValue @Double "Double" + , parseValue @Int "Int" + , parseValue @Natural "Natural" + , parseValue @Integer "Integer" + , parseValue @Int8 "Int8" + , parseValue @Int16 "Int16" + , parseValue @Int32 "Int32" + , parseValue @Int64 "Int64" + , parseValue @Word "Word" + , parseValue @Word8 "Word8" + , parseValue @Word16 "Word16" + , parseValue @Word32 "Word32" + , parseValue @Word64 "Word64" + , parseValue @T.Text "T.Text" + , parseValue @LT.Text "LT.Text" + , parseValue @DV.Version "Version" + , parseValue @Scientific "Scientific" + , parseValue @IntSet "IntSet" + , parseValue @UUID "UUID" + , parseValue @CTime "CTime" + , parseValue @ZonedTime "ZonedTime" + , parseValue @LocalTime "LocalTime" + , parseValue @TimeOfDay "TimeOfDay" + , parseValue @UTCTime "UTCTime" + , parseValue @NominalDiffTime "NominalDiffTime" + , parseValue @DiffTime "DiffTime" + , parseValue @Day "Day" + , parseValue @DotNetTime "DotNetTime" + , parseValue @Value "Value" + + , parseValue @(Ratio Int) "Ratio" + , parseValue @(Fixed E12) "Fixed" + , parseValue @(Proxy ()) "Proxy" + + , parseValue @(Identity T.Text) "Identity" + , parseValue @(First T.Text) "First" + , parseValue @(Last T.Text) "Last" + , parseValue @(Min T.Text) "Min" + , parseValue @(Max T.Text) "Max" + , parseValue @(Dual T.Text) "Dual" + + , parseValue @([Int]) "[]" + , parseValue @(IntMap Bool) "IntMap" + , parseValue @(NonEmpty Int) "NonEmpty" + , parseValue @(Seq T.Text) "Seq" + , parseValue @(Tree T.Text) "Tree" + + , parseValue @(Const T.Text ()) "Const" + , parseValue @(Maybe T.Text) "Maybe" + , parseValue @(Maybe T.Text) "Maybe2" + , parseValue @(Either T.Text Bool) "Either" + , parseValue @(Either T.Text Bool) "Either2" + + , parseValue @(DList Int) "DList" + , parseValue @(V.Vector Int) "V.Vector" + , parseValue @(VS.Vector Int) "VS.Vector" + , parseValue @(VP.Vector Int) "VP.Vector" + , parseValue @(VU.Vector Int) "VU.Vector" + + , parseValue @(Set Int) "Set" + , parseValue @(Map T.Text Int) "Map" + , parseValue @(HashSet Int) "HashSet" + , parseValue @(HashMap T.Text Int) "HashMap" + + , parseValue @(Int, Bool) "Tuple2" + , parseValue @(Int, Bool, T.Text) "Tuple3" + , parseValue @(Int, Bool, T.Text, [Int]) "Tuple4" + , parseValue @(Int, Bool, T.Text, [Int], Double) "Tuple5" + ] + + +-------------------------------- + +toJSONEquivalence :: TestTree +toJSONEquivalence = testGroup "safeToJSON === toJSON" + [ toJSONTest @Bool "Bool" + , toJSONTest @Ordering "Ordering" + , toJSONTest @() "()" + , toJSONTest @Char "Char" + , toJSONTest @Float "Float" + , toJSONTest @Double "Double" + , toJSONTest @Int "Int" + , toJSONTest @Natural "Natural" + , toJSONTest @Integer "Integer" + , toJSONTest @Int8 "Int8" + , toJSONTest @Int16 "Int16" + , toJSONTest @Int32 "Int32" + , toJSONTest @Int64 "Int64" + , toJSONTest @Word "Word" + , toJSONTest @Word8 "Word8" + , toJSONTest @Word16 "Word16" + , toJSONTest @Word32 "Word32" + , toJSONTest @Word64 "Word64" + , toJSONTest @T.Text "T.Text" + , toJSONTest @LT.Text "LT.Text" + , toJSONTest @DV.Version "DV.Version" + , toJSONTest @Scientific "Scientific" + , toJSONTest @IntSet "IntSet" + , toJSONTest @UUID "UUID" + , toJSONTest @CTime "CTime" + , toJSONTest @ZonedTime "ZonedTime" + , toJSONTest @LocalTime "LocalTime" + , toJSONTest @TimeOfDay "TimeOfDay" + , toJSONTest @UTCTime "UTCTime" + , toJSONTest @NominalDiffTime "NominalDiffTime" + , toJSONTest @DiffTime "DiffTime" + , toJSONTest @Day "Day" + , toJSONTest @DotNetTime "DotNetTime" + , toJSONTest @Value "Value" + + , toJSONTest @(Ratio Int) "Ratio" + , toJSONTest @(Fixed E12) "Fixed" + , toJSONTest @(Proxy ()) "Proxy" + , toJSONTest @(Identity T.Text) "Identity" + , toJSONTest @(First T.Text) "First" + , toJSONTest @(Last T.Text) "Last" + , toJSONTest @(Min T.Text) "Min" + , toJSONTest @(Max T.Text) "Max" + , toJSONTest @(Dual T.Text) "Dual" + , toJSONTest @([Int]) "[]" + , toJSONTest @(IntMap Bool) "IntMap" + , toJSONTest @(NonEmpty Int) "NonEmpty" + , toJSONTest @(Seq T.Text) "Seq" + , toJSONTest @(Tree T.Text) "Tree" + , toJSONTest @(Const T.Text ()) "Const" + , toJSONTest @(Maybe T.Text) "Maybe" + , toJSONTest @(Maybe T.Text) "Maybe2" + , toJSONTest @(Either T.Text Bool) "Either" + , toJSONTest @(Either T.Text Bool) "Either2" + , toJSONTest @(DList Int) "DList" + , toJSONTest @(V.Vector Int) "V.Vector" + , toJSONTest @(VS.Vector Int) "VS.Vector" + , toJSONTest @(VP.Vector Int) "VP.Vector" + , toJSONTest @(VU.Vector Int) "VU.Vector" + , toJSONTest @(Set Int) "Set" + , toJSONTest @(Map T.Text Int) "Map" + , toJSONTest @(HashSet Int) "HashSet" + , toJSONTest @(HashMap T.Text Int) "HashMap" + , toJSONTest @(Int, Bool) "Tuple2" + , toJSONTest @(Int, Bool, T.Text) "Tuple3" + , toJSONTest @(Int, Bool, T.Text, [Int]) "Tuple4" + , toJSONTest @(Int, Bool, T.Text, [Int], Double) "Tuple5" + ] + +fromJSONEquivalence :: TestTree +fromJSONEquivalence = testGroup "safeFromJSON === fromJSON" + [ fromJSONTest @Bool "Bool" + , fromJSONTest @Ordering "Ordering" + , fromJSONTest @() "Unit" + , fromJSONTest @Char "Char" + , fromJSONTest @Float "Float" + , fromJSONTest @Double "Double" + , fromJSONTest @Int "Int" + , fromJSONTest @Natural "Natural" + , fromJSONTest @Integer "Integer" + , fromJSONTest @Int8 "Int8" + , fromJSONTest @Int16 "Int16" + , fromJSONTest @Int32 "Int32" + , fromJSONTest @Int64 "Int64" + , fromJSONTest @Word "Word" + , fromJSONTest @Word8 "Word8" + , fromJSONTest @Word16 "Word16" + , fromJSONTest @Word32 "Word32" + , fromJSONTest @Word64 "Word64" + , fromJSONTest @T.Text "T.Text" + , fromJSONTest @LT.Text "LT.Text" + , fromJSONTest @DV.Version "Version" + , fromJSONTest @Scientific "Scientific" + , fromJSONTest @IntSet "IntSet" + , fromJSONTest @UUID "UUID" + , fromJSONTest @CTime "CTime" + -- , fromJSONTest @ZonedTime "ZonedTime" -- No Eq instance + , fromJSONTest @LocalTime "LocalTime" + , fromJSONTest @TimeOfDay "TimeOfDay" + , fromJSONTest @UTCTime "UTCTime" + , fromJSONTest @NominalDiffTime "NominalDiffTime" + , fromJSONTest @DiffTime "DiffTime" + , fromJSONTest @Day "Day" + , fromJSONTest @DotNetTime "DotNetTime" + , fromJSONTest @Value "Value" + + , fromJSONTest @(Ratio Int) "Ratio" + , fromJSONTest @(Fixed E12) "Fixed" + , fromJSONTest @(Proxy ()) "Proxy" + , fromJSONTest @(Identity T.Text) "Identity" + , fromJSONTest @(First T.Text) "First" + , fromJSONTest @(Last T.Text) "Last" + , fromJSONTest @(Min T.Text) "Min" + , fromJSONTest @(Max T.Text) "Max" + , fromJSONTest @(Dual T.Text) "Dual" + , fromJSONTest @([Int]) "[]" + , fromJSONTest @(IntMap Bool) "IntMap" + , fromJSONTest @(NonEmpty Int) "NonEmpty" + , fromJSONTest @(Seq T.Text) "Seq" + , fromJSONTest @(Tree T.Text) "Tree" + , fromJSONTest @(Const T.Text ()) "Const" + , fromJSONTest @(Maybe T.Text) "Maybe" + , fromJSONTest @(Maybe T.Text) "Maybe2" + , fromJSONTest @(Either T.Text Bool) "Either" + , fromJSONTest @(Either T.Text Bool) "Either2" + , fromJSONTest @(DList Int) "DList" + , fromJSONTest @(V.Vector Int) "V.Vector" + , fromJSONTest @(VS.Vector Int) "VS.Vector" + , fromJSONTest @(VP.Vector Int) "VP.Vector" + , fromJSONTest @(VU.Vector Int) "VU.Vector" + , fromJSONTest @(Set Int) "Set" + , fromJSONTest @(Map T.Text Int) "Map" + , fromJSONTest @(HashSet Int) "HashSet" + , fromJSONTest @(HashMap T.Text Int) "HashMap" + , fromJSONTest @(Int, Bool) "Tuple2" + , fromJSONTest @(Int, Bool, T.Text) "Tuple3" + , fromJSONTest @(Int, Bool, T.Text, [Int]) "Tuple4" + , fromJSONTest @(Int, Bool, T.Text, [Int], Double) "Tuple5" + ] diff --git a/test/SafeAeson.hs b/test/SafeAeson.hs new file mode 100644 --- /dev/null +++ b/test/SafeAeson.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module SafeAeson where + + +import Data.Aeson (Value) +import qualified Data.Aeson as A +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import System.IO.Temp (withTempDirectory) +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Aeson.Safe +import Types + + +encodeDecodeTests :: TestTree +encodeDecodeTests = testGroup "Encoding/Decoding (Data.Aeson.Safe)" + [ parseFile @NoVersion "decodeFile (noversion)" noVersionPath + , parseFile' @NoVersion "decodeFile' (noversion)" noVersionPath + , parseBigFile "decodeFile (primitives)" primitivesPath + , writeToFile "encodeFile" + , parseValue @NoVersion "decode (noversion)" + , parseValue' @NoVersion "decode' (noversion)" + , encodeType "encode" + ] + + +jsonPath :: FilePath +jsonPath = "test/json" + +noVersionPath :: FilePath +noVersionPath = jsonPath ++ "/noversion.json" + +primitivesPath :: FilePath +primitivesPath = jsonPath ++ "/primitives.json" + +noVersionType :: NoVersion +noVersionType = NoVersion 23986 + +parseBigFile :: String -> FilePath -> TestTree +parseBigFile s fp = testCase s $ do + a <- decodeFileStrict @Value fp + b <- A.decodeFileStrict fp + b @=? a + c <- decodeFileStrict' @Value fp + d <- A.decodeFileStrict' fp + d @=? c + e <- eitherDecodeFileStrict @Value fp + x <- A.eitherDecodeFileStrict fp + x @=? e + y <- eitherDecodeFileStrict' @Value fp + z <- A.eitherDecodeFileStrict' fp + z @=? y + +parseValue :: forall a. (SafeJSON a, Eq a, Show a) => String -> TestTree +parseValue s = testCase s $ do + lbs <- LBS.readFile noVersionPath + decode @a lbs @=? A.decode lbs + eitherDecode @a lbs @=? A.eitherDecode lbs + + bs <- BS.readFile noVersionPath + decodeStrict @a bs @=? A.decodeStrict bs + eitherDecodeStrict @a bs @=? A.eitherDecodeStrict bs + +parseValue' :: forall a. (SafeJSON a, Eq a, Show a) => String -> TestTree +parseValue' s = testCase s $ do + lbs <- LBS.readFile noVersionPath + decode' @a lbs @=? A.decode' lbs + eitherDecode' @a lbs @=? A.eitherDecode' lbs + + bs <- BS.readFile noVersionPath + decodeStrict' @a bs @=? A.decodeStrict' bs + eitherDecodeStrict' @a bs @=? A.eitherDecodeStrict' bs + +parseFile :: forall a. (SafeJSON a, Eq a, Show a) => String -> FilePath -> TestTree +parseFile s fp = testCase s $ do + a <- decodeFileStrict @Value fp + b <- A.decodeFileStrict fp + b @=? a + + c <- decodeFileStrict @a fp + d <- A.decodeFileStrict fp + d @=? c + + e <- eitherDecodeFileStrict @Value fp + x <- A.eitherDecodeFileStrict fp + x @=? e + + y <- eitherDecodeFileStrict @a fp + z <- A.eitherDecodeFileStrict fp + z @=? y + +parseFile' :: forall a. (SafeJSON a, Eq a, Show a) => String -> FilePath -> TestTree +parseFile' s fp = testCase s $ do + a <- decodeFileStrict' @Value fp + b <- A.decodeFileStrict' fp + b @=? a + + c <- decodeFileStrict' @a fp + d <- A.decodeFileStrict' fp + d @=? c + + e <- eitherDecodeFileStrict' @Value fp + x <- A.eitherDecodeFileStrict' fp + x @=? e + + y <- eitherDecodeFileStrict' @a fp + z <- A.eitherDecodeFileStrict' fp + z @=? y + +writeToFile :: String -> TestTree +writeToFile s = testCase s $ do + withTempDirectory "test/json" "encode" $ \dir -> do + let file1 = dir ++ "/test.json" + file2 = dir ++ "/test2.json" + encodeFile file1 noVersionType + A.encodeFile file2 noVersionType + x <- A.decodeFileStrict @NoVersion file1 + y <- A.decodeFileStrict file2 + y @=? x + +encodeType :: String -> TestTree +encodeType s = testCase s $ + encode noVersionType @=? A.encode noVersionType diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,26 @@ +module Main where + + +import Data.Proxy +import Test.Tasty as Tasty + +import Data.SafeJSON (Version) + +import ConsistencyTests +import MigrationTests +import PrimitiveTests +import SafeAeson +import VersionNum + + +main :: IO () +main = Tasty.defaultMain tests + +tests :: TestTree +tests = testGroup "\nSafeJSON" + [ numTest (Proxy :: Proxy (Version a)) + , primitiveTests + , consistencyTests + , encodeDecodeTests + , migrationTests + ] diff --git a/test/Types.hs b/test/Types.hs new file mode 100644 --- /dev/null +++ b/test/Types.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +module Types where + + +import Control.Monad (when) +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Hashable (Hashable(..)) +import Data.Maybe (isJust) +#if MIN_VERSION_base(4,11,0) +#else +import Data.Monoid ((<>)) +#endif +import Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.UUID as UUID + +import Data.SafeJSON + + +---------------------------------------------------------- +-- Versioned chain +---------------------------------------------------------- + +checkType :: String -> Object -> Parser () +checkType t o = do + typ <- o .: "type" + when (typ /= t) $ fail $ "wrong type (" ++ t ++ ")" + +newtype NoVersion = NoVersion Int deriving (Eq, Show) +instance SafeJSON NoVersion where version = noVersion + +instance FromJSON NoVersion where + parseJSON = withObject "NoVersion" $ \o -> do + checkType "test" o + i <- o .: "int" + return $ NoVersion i + +instance ToJSON NoVersion where + toJSON (NoVersion i) = object + [ "type" .= String "test" + , "int" .= i + ] + + +newtype Version0 = Version0 Text deriving (Eq, Show) +instance SafeJSON Version0 where kind = extended_base + +instance FromJSON Version0 where + parseJSON = withObject "Version0" $ \o -> do + checkType "test" o + t <- o .: "text" + return $ Version0 t + +instance ToJSON Version0 where + toJSON (Version0 t) = object + [ "type" .= String "test" + , "text" .= t + ] + +instance Migrate (Reverse Version0) where + type MigrateFrom (Reverse Version0) = Version1 + migrate (Version1 t) = Reverse $ Version0 t + + +newtype Version1 = Version1 Text deriving (Eq, Show) +instance SafeJSON Version1 where version = 1; kind = extended_extension + +instance FromJSON Version1 where + parseJSON = withObject "Version1" $ \o -> do + checkType "test" o + t <- o .: "text" + return $ Version1 t + +instance ToJSON Version1 where + toJSON (Version1 t) = object + [ "type" .= String "test" + , "text" .= t + ] + +instance Migrate Version1 where + type MigrateFrom Version1 = NoVersion + migrate (NoVersion i) = Version1 . pack . show $ i + +instance Migrate (Reverse Version1) where + type MigrateFrom (Reverse Version1) = Version2 + migrate (Version2 ts) = Reverse . Version1 $ intercalate ", " ts + + +newtype Version2 = Version2 [Text] deriving (Eq, Show) +instance SafeJSON Version2 where version = 2; kind = extension + +instance FromJSON Version2 where + parseJSON = withObject "Version2" $ \o -> do + checkType "test" o + t <- o .: "texts" + return $ Version2 t + +instance ToJSON Version2 where + toJSON (Version2 ts) = object + [ "type" .= String "test" + , "texts" .= ts + ] + +instance Migrate Version2 where + type MigrateFrom Version2 = Version1 + migrate (Version1 t) = Version2 [t] + + +data Version3 = Version3 { + v3texts :: [Text], + v3Closed :: Bool +} deriving (Eq, Show) + +instance SafeJSON Version3 where version = 3; kind = extended_extension + +instance FromJSON Version3 where + parseJSON = withObject "Version3" $ \o -> do + checkType "test" o + ts <- o .: "texts" + b <- o .: "closed" + return $ Version3 ts b + +instance ToJSON Version3 where + toJSON (Version3 ts b) = object + [ "type" .= String "test" + , "texts" .= ts + , "closed" .= b + ] + +instance Migrate Version3 where + type MigrateFrom Version3 = Version2 + migrate (Version2 ts) = Version3 ts False + +instance Migrate (Reverse Version3) where + type MigrateFrom (Reverse Version3) = Version4 + migrate (Version4 ts mTime) = Reverse $ Version3 ts $ isJust mTime + + +data Version4 = Version4 { + v4texts :: [Text], + v4TimeClosed :: Maybe UTCTime +} deriving (Eq, Show, Ord) + +instance SafeJSON Version4 where version = 4; kind = extension + +instance FromJSON Version4 where + parseJSON = withObject "Version4" $ \o -> do + checkType "test" o + ts <- o .: "texts" + c <- o .:? "closed" + return $ Version4 ts c + +instance ToJSON Version4 where + toJSON (Version4 ts c) = object $ + [ "type" .= String "test" + , "texts" .= ts + ] ++ ["closed" .= x | Just x <- [c]] + +instance Migrate Version4 where + type MigrateFrom Version4 = Version3 + migrate (Version3 ts b) = Version4 ts time + where time = if b then Just (posixSecondsToUTCTime 0) else Nothing + +---------------------------------------------------------- +-- Simple Version +---------------------------------------------------------- + +data SimpleVersion1 = SimpleVersion1 { + s1UUID :: UUID, + s1Name :: Text +} deriving (Eq, Show) + +instance FromJSON SimpleVersion1 where + parseJSON = withText "SimpleVersion1" $ \t -> + let (ident,name) = T.span (/= ':') t + in case UUID.fromText ident of + Nothing -> fail "non-UUID prefix" + Just uuid -> pure $ SimpleVersion1 uuid $ T.drop 1 name + +instance ToJSON SimpleVersion1 where + toJSON (SimpleVersion1 uuid name) = String $ UUID.toText uuid <> ":" <> name + +instance SafeJSON SimpleVersion1 where + version = 1 + kind = extension + +instance Migrate SimpleVersion1 where + type MigrateFrom SimpleVersion1 = UUID + migrate uuid = SimpleVersion1 uuid "" + +data BadVersion = BadVersion Text deriving (Eq, Show) +instance FromJSON BadVersion where parseJSON = withText "BadVersion" $ pure . BadVersion +instance ToJSON BadVersion where toJSON (BadVersion t) = String t +instance SafeJSON BadVersion where version = 8 + +-- Used for the HashSet migration test +instance Hashable Version4 where + hashWithSalt i = hashWithSalt i . encode diff --git a/test/VersionNum.hs b/test/VersionNum.hs new file mode 100644 --- /dev/null +++ b/test/VersionNum.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module VersionNum where + + +import Data.Proxy +import Test.Tasty as Tasty +import Test.Tasty.QuickCheck as Tasty + + +numTest :: (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> TestTree +numTest p = testGroup "Version's Num instance" $ + ($p) <$> [plusTest, minusTest, multTest, negateTest, absSignumTest] + +plusTest :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> TestTree +plusTest _ = testGroup "Plus laws" + [ plusAssociative + , plusCommutative + , plusIdentity + ] + where plusAssociative = testProperty "Associative (+)" go + where go a b c = (a :: a) + (b + c) == (a + b) + c + plusCommutative = testProperty "Commutative (+)" go + where go a b = (a :: a) + b == b + a + plusIdentity = testProperty "Identity (+)" go + where go a = (a :: a) + fromInteger 0 == a + +minusTest :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> TestTree +minusTest _ = testProperty "Minus law" $ \a -> (a :: a) - a == fromInteger 0 + +multTest :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> TestTree +multTest _ = testGroup "Plus laws" + [ multAssociative + , multCommutative + , multIdentity + ] + where multAssociative = testProperty "Associative (*)" go + where go a b c = (a :: a) * (b * c) == (a * b) * c + multCommutative = testProperty "Commutative (*)" go + where go a b = (a :: a) * b == b * a + multIdentity = testProperty "Identity (*)" go + where go a = (a :: a) * fromInteger 1 == a + +negateTest :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> TestTree +negateTest _ = testGroup "Negate laws" + [ negateToZero + , doubleNegate + ] + where negateToZero = testProperty "Self added to negated self == identity" $ + \a -> (a :: a) + negate a == fromInteger 0 + doubleNegate = testProperty "Double negation is original" $ + \a -> negate (negate a) == (a :: a) + +absSignumTest :: forall a. (Num a, Eq a, Arbitrary a, Show a) => Proxy a -> TestTree +absSignumTest _ = testProperty "Absolute time signum is original" $ + \a -> abs a * signum a == (a :: a)