diff --git a/servant-aeson-specs.cabal b/servant-aeson-specs.cabal --- a/servant-aeson-specs.cabal +++ b/servant-aeson-specs.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: servant-aeson-specs -version: 0.1 +version: 0.2 synopsis: generic tests for aeson serialization in servant description: tests for aeson serialization in servant category: Web @@ -30,11 +30,16 @@ , hspec , QuickCheck , servant == 0.4.* + , directory + , filepath + , random + , aeson-pretty exposed-modules: - Servant.Aeson.RoundtripSpecs - Servant.Aeson.RoundtripSpecs.Internal - Test.Aeson.RoundtripSpecs - Test.Aeson.RoundtripSpecs.Internal + Servant.Aeson.GenericSpecs + Servant.Aeson.Internal + Test.Aeson.GenericSpecs + Test.Aeson.Internal.GoldenSpecs + Test.Aeson.Internal.RoundtripSpecs default-language: Haskell2010 test-suite spec @@ -51,15 +56,28 @@ , hspec , QuickCheck , servant == 0.4.* + , directory + , filepath + , random + , aeson-pretty , hspec-core , temporary , doctest + , mockery + , silently + , quickcheck-instances + , string-conversions + , text other-modules: DoctestSpec + Servant.Aeson.GoldenSpecsSpec Servant.Aeson.RoundtripSpecsSpec + Test.Aeson.GoldenSpecsSpec Test.Aeson.RoundtripSpecsSpec - Servant.Aeson.RoundtripSpecs - Servant.Aeson.RoundtripSpecs.Internal - Test.Aeson.RoundtripSpecs - Test.Aeson.RoundtripSpecs.Internal + Test.Utils + Servant.Aeson.GenericSpecs + Servant.Aeson.Internal + Test.Aeson.GenericSpecs + Test.Aeson.Internal.GoldenSpecs + Test.Aeson.Internal.RoundtripSpecs default-language: Haskell2010 diff --git a/src/Servant/Aeson/GenericSpecs.hs b/src/Servant/Aeson/GenericSpecs.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Aeson/GenericSpecs.hs @@ -0,0 +1,66 @@ + +-- | If you're using [servant](http://haskell-servant.readthedocs.org/) with +-- either [servant-client](http://hackage.haskell.org/package/servant-client) +-- or [servant-server](http://hackage.haskell.org/package/servant-server) there +-- will be types included in your APIs that servant will convert to and from +-- JSON. (At least for most common APIs.) This module allows you to +-- generically obtain test-suites for JSON serialization and deserialization of +-- those types. +-- +-- Here's an example: +-- +-- >>> :set -XTypeOperators +-- >>> :set -XDataKinds +-- >>> :set -XDeriveGeneric +-- +-- >>> import Servant.API +-- >>> import Test.Hspec (hspec) +-- >>> import GHC.Generics (Generic) +-- >>> import Data.Aeson (ToJSON, FromJSON) +-- >>> import Test.QuickCheck (Arbitrary(..), oneof) +-- +-- >>> data Foo = Foo { a :: String, b :: Int } deriving (Eq, Show, Generic) +-- >>> instance FromJSON Foo +-- >>> instance ToJSON Foo +-- >>> :{ +-- instance Arbitrary Foo where +-- arbitrary = Foo <$> arbitrary <*> arbitrary +-- :} +-- +-- >>> data Bar = BarA | BarB { bar :: Bool } deriving (Eq, Show, Generic) +-- >>> instance FromJSON Bar +-- >>> instance ToJSON Bar +-- >>> :{ +-- instance Arbitrary Bar where +-- arbitrary = oneof $ +-- pure BarA : +-- (BarB <$> arbitrary) : +-- [] +-- :} +-- +-- +-- >>> type Api = "post" :> ReqBody '[JSON] Foo :> Get '[JSON] Bar +-- >>> let api = Proxy :: Proxy Api +-- >>> hspec $ apiRoundtripSpecs api +-- +-- JSON encoding of Bar +-- allows to encode values with aeson and read them back +-- JSON encoding of Foo +-- allows to encode values with aeson and read them back +-- +-- Finished in ... seconds +-- 2 examples, 0 failures + +module Servant.Aeson.GenericSpecs ( + apiRoundtripSpecs, + apiGoldenSpecs, + apiSpecs, + usedTypes, + + -- * re-exports + Proxy(..), +) where + +import Data.Proxy + +import Servant.Aeson.Internal diff --git a/src/Servant/Aeson/Internal.hs b/src/Servant/Aeson/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Aeson/Internal.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Internal module, use at your own risk. +module Servant.Aeson.Internal where + +import Data.Aeson +import Data.Function +import Data.List +import Data.Proxy +import Data.Typeable +import GHC.TypeLits +import Servant.API +import Test.Hspec +import Test.QuickCheck + +import Test.Aeson.Internal.GoldenSpecs +import Test.Aeson.Internal.RoundtripSpecs + +-- | Allows to obtain roundtrip tests for JSON serialization for all types used +-- in a [servant](http://haskell-servant.readthedocs.org/) api. +-- +-- See also 'Test.Aeson.GenericSpecs.roundtripSpecs'. +apiRoundtripSpecs :: (HasGenericSpecs api) => Proxy api -> Spec +apiRoundtripSpecs = sequence_ . map roundtrip . mkRoundtripSpecs + +-- | Allows to obtain golden tests for JSON serialization for all types used +-- in a [servant](http://haskell-servant.readthedocs.org/) api. +-- +-- See also 'Test.Aeson.GenericSpecs.goldenSpecs'. +apiGoldenSpecs :: HasGenericSpecs api => Proxy api -> Spec +apiGoldenSpecs proxy = sequence_ $ map golden $ mkRoundtripSpecs proxy + +-- | Combination of 'apiRoundtripSpecs' and 'apiGoldenSpecs'. +apiSpecs :: (HasGenericSpecs api) => Proxy api -> Spec +apiSpecs proxy = sequence_ $ map (\ ts -> roundtrip ts >> golden ts) $ mkRoundtripSpecs proxy + +-- | Allows to retrieve a list of all used types in a +-- [servant](http://haskell-servant.readthedocs.org/) api as 'TypeRep's. +usedTypes :: (HasGenericSpecs api) => Proxy api -> [TypeRep] +usedTypes = map typ . mkRoundtripSpecs + +mkRoundtripSpecs :: (HasGenericSpecs api) => Proxy api -> [TypeSpec] +mkRoundtripSpecs = normalize . collectRoundtripSpecs + where + normalize = nubBy ((==) `on` typ) . sortBy (compare `on` (show . typ)) + +class HasGenericSpecs api where + collectRoundtripSpecs :: Proxy api -> [TypeSpec] + +instance (HasGenericSpecs a, HasGenericSpecs b) => HasGenericSpecs (a :<|> b) where + collectRoundtripSpecs Proxy = + collectRoundtripSpecs (Proxy :: Proxy a) ++ + collectRoundtripSpecs (Proxy :: Proxy b) + +instance (MkTypeSpecs response) => + HasGenericSpecs (Get contentTypes response) where + + collectRoundtripSpecs Proxy = do + mkTypeSpecs (Proxy :: Proxy response) + +instance (MkTypeSpecs response) => + HasGenericSpecs (Post contentTypes response) where + + collectRoundtripSpecs Proxy = mkTypeSpecs (Proxy :: Proxy response) + +instance (MkTypeSpecs body, HasGenericSpecs api) => + HasGenericSpecs (ReqBody contentTypes body :> api) where + + collectRoundtripSpecs Proxy = + mkTypeSpecs (Proxy :: Proxy body) ++ + collectRoundtripSpecs (Proxy :: Proxy api) + +instance HasGenericSpecs api => HasGenericSpecs ((path :: Symbol) :> api) where + collectRoundtripSpecs Proxy = collectRoundtripSpecs (Proxy :: Proxy api) + +instance HasGenericSpecs api => HasGenericSpecs (MatrixParam name a :> api) where + collectRoundtripSpecs Proxy = collectRoundtripSpecs (Proxy :: Proxy api) + +data TypeSpec + = TypeSpec { + typ :: TypeRep, + roundtrip :: Spec, + golden :: Spec + } + +-- 'mkTypeSpecs' has to be implemented as a method of a separate class, because we +-- want to be able to have a specialized implementation for lists. +class MkTypeSpecs a where + mkTypeSpecs :: Proxy a -> [TypeSpec] + +instance (Typeable a, Eq a, Show a, Arbitrary a, ToJSON a, FromJSON a) => MkTypeSpecs a where + + mkTypeSpecs proxy = pure $ + TypeSpec { + typ = typeRep proxy, + roundtrip = roundtripSpecs proxy, + golden = goldenSpecs proxy + } + +-- The following instances will only test json serialization of element types. +-- As we trust aeson to do the right thing for standard container types, we +-- don't need to test that. (This speeds up test suites immensely.) + +instance {-# OVERLAPPING #-} + (Eq a, Show a, Typeable a, Arbitrary a, ToJSON a, FromJSON a) => + MkTypeSpecs [a] where + + mkTypeSpecs Proxy = pure $ + TypeSpec { + typ = typeRep proxy, + roundtrip = genericAesonRoundtripWithNote proxy (Just note), + golden = goldenSpecsWithNote proxy (Just note) + } + where + proxy = Proxy :: Proxy a + note = "(as element-type in [])" + +instance {-# OVERLAPPING #-} + (Eq a, Show a, Typeable a, Arbitrary a, ToJSON a, FromJSON a) => + MkTypeSpecs (Maybe a) where + + mkTypeSpecs Proxy = pure $ + TypeSpec { + typ = typeRep proxy, + roundtrip = genericAesonRoundtripWithNote proxy (Just note), + golden = goldenSpecsWithNote proxy (Just note) + } + where + proxy = Proxy :: Proxy a + note = "(as element-type in Maybe)" + +-- We trust aeson to be correct for (). +instance {-# OVERLAPPING #-} + MkTypeSpecs () where + + mkTypeSpecs Proxy = [] diff --git a/src/Servant/Aeson/RoundtripSpecs.hs b/src/Servant/Aeson/RoundtripSpecs.hs deleted file mode 100644 --- a/src/Servant/Aeson/RoundtripSpecs.hs +++ /dev/null @@ -1,63 +0,0 @@ - --- | If you're using [servant](http://haskell-servant.readthedocs.org/) with --- either [servant-client](http://hackage.haskell.org/package/servant-client) --- or [servant-server](http://hackage.haskell.org/package/servant-server) there --- will be types included in your APIs that servant will convert to and from --- JSON. (At least for most common APIs.) 'roundtripSpecs' allows you to --- generically obtain a test-suite, that makes sure for those types, that they --- can be serialized to JSON and read back to Haskell successfully. --- --- Here's an example: --- --- >>> :set -XTypeOperators --- >>> :set -XDataKinds --- >>> :set -XDeriveGeneric --- --- >>> import Servant.API --- >>> import Test.Hspec (hspec) --- >>> import GHC.Generics (Generic) --- >>> import Data.Aeson (ToJSON, FromJSON) --- >>> import Test.QuickCheck (Arbitrary(..), oneof) --- --- >>> data Foo = Foo { a :: String, b :: Int } deriving (Eq, Show, Generic) --- >>> instance FromJSON Foo --- >>> instance ToJSON Foo --- >>> :{ --- instance Arbitrary Foo where --- arbitrary = Foo <$> arbitrary <*> arbitrary --- :} --- --- >>> data Bar = BarA | BarB { bar :: Bool } deriving (Eq, Show, Generic) --- >>> instance FromJSON Bar --- >>> instance ToJSON Bar --- >>> :{ --- instance Arbitrary Bar where --- arbitrary = oneof $ --- pure BarA : --- (BarB <$> arbitrary) : --- [] --- :} --- --- --- >>> type Api = "post" :> ReqBody '[JSON] Foo :> Get '[JSON] Bar --- >>> let api = Proxy :: Proxy Api --- >>> hspec $ roundtripSpecs api --- --- JSON encoding of Bar --- allows to encode values with aeson and read them back --- JSON encoding of Foo --- allows to encode values with aeson and read them back --- --- Finished in ... seconds --- 2 examples, 0 failures -module Servant.Aeson.RoundtripSpecs ( - roundtripSpecs, - usedTypes, - - -- * re-exports - Proxy(..), -) where - -import Data.Proxy - -import Servant.Aeson.RoundtripSpecs.Internal diff --git a/src/Servant/Aeson/RoundtripSpecs/Internal.hs b/src/Servant/Aeson/RoundtripSpecs/Internal.hs deleted file mode 100644 --- a/src/Servant/Aeson/RoundtripSpecs/Internal.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Internal module, use at your own risk. -module Servant.Aeson.RoundtripSpecs.Internal where - -import Data.Aeson -import Data.Function -import Data.List -import Data.Proxy -import Data.Typeable -import GHC.TypeLits -import Servant.API -import Test.Hspec -import Test.QuickCheck - -import Test.Aeson.RoundtripSpecs.Internal - --- | Allows to obtain roundtrip tests for JSON serialization for all types used --- in a [servant](http://haskell-servant.readthedocs.org/) api. --- --- See also 'Test.Aeson.RoundtripSpecs.genericAesonRoundtrip'. -roundtripSpecs :: (HasRoundtripSpecs api) => Proxy api -> Spec -roundtripSpecs = sequence_ . map snd . mkRoundtripSpecs - --- | Allows to retrieve a list of all used types in a --- [servant](http://haskell-servant.readthedocs.org/) api as 'TypeRep's. -usedTypes :: (HasRoundtripSpecs api) => Proxy api -> [TypeRep] -usedTypes = map fst . mkRoundtripSpecs - -mkRoundtripSpecs :: (HasRoundtripSpecs api) => Proxy api -> [(TypeRep, Spec)] -mkRoundtripSpecs = normalize . collectRoundtripSpecs - where - normalize = nubBy ((==) `on` fst) . sortBy (compare `on` (show . fst)) - -class HasRoundtripSpecs api where - collectRoundtripSpecs :: Proxy api -> [(TypeRep, Spec)] - -instance (HasRoundtripSpecs a, HasRoundtripSpecs b) => HasRoundtripSpecs (a :<|> b) where - collectRoundtripSpecs Proxy = - collectRoundtripSpecs (Proxy :: Proxy a) ++ - collectRoundtripSpecs (Proxy :: Proxy b) - -instance (MkSpec response) => - HasRoundtripSpecs (Get contentTypes response) where - - collectRoundtripSpecs Proxy = do - mkSpec (Proxy :: Proxy response) - -instance (MkSpec response) => - HasRoundtripSpecs (Post contentTypes response) where - - collectRoundtripSpecs Proxy = mkSpec (Proxy :: Proxy response) - -instance (MkSpec body, HasRoundtripSpecs api) => - HasRoundtripSpecs (ReqBody contentTypes body :> api) where - - collectRoundtripSpecs Proxy = - mkSpec (Proxy :: Proxy body) ++ - collectRoundtripSpecs (Proxy :: Proxy api) - -instance HasRoundtripSpecs api => HasRoundtripSpecs ((path :: Symbol) :> api) where - collectRoundtripSpecs Proxy = collectRoundtripSpecs (Proxy :: Proxy api) - -instance HasRoundtripSpecs api => HasRoundtripSpecs (MatrixParam name a :> api) where - collectRoundtripSpecs Proxy = collectRoundtripSpecs (Proxy :: Proxy api) - --- 'mkSpec' has to be implemented as a method of a separate class, because we --- want to be able to have a specialized implementation for lists. -class MkSpec a where - mkSpec :: Proxy a -> [(TypeRep, Spec)] - -instance (Typeable a, Eq a, Show a, Arbitrary a, ToJSON a, FromJSON a) => MkSpec a where - - mkSpec proxy = [(typeRep proxy, genericAesonRoundtrip proxy)] - --- This will only test json serialization of the element type. As we trust aeson --- to do the right thing for lists, we don't need to test that. (This speeds up --- test suites immensely.) -instance {-# OVERLAPPING #-} - (Eq a, Show a, Typeable a, Arbitrary a, ToJSON a, FromJSON a) => - MkSpec [a] where - - mkSpec Proxy = [(typeRep proxy, genericAesonRoundtripWithNote proxy (Just note))] - where - proxy = Proxy :: Proxy a - note = "(as element-type in [])" diff --git a/src/Test/Aeson/GenericSpecs.hs b/src/Test/Aeson/GenericSpecs.hs new file mode 100644 --- /dev/null +++ b/src/Test/Aeson/GenericSpecs.hs @@ -0,0 +1,15 @@ + +module Test.Aeson.GenericSpecs ( + roundtripSpecs, + goldenSpecs, + + shouldBeIdentity, + + -- * re-exports + Proxy(..), +) where + +import Data.Proxy + +import Test.Aeson.Internal.GoldenSpecs +import Test.Aeson.Internal.RoundtripSpecs diff --git a/src/Test/Aeson/Internal/GoldenSpecs.hs b/src/Test/Aeson/Internal/GoldenSpecs.hs new file mode 100644 --- /dev/null +++ b/src/Test/Aeson/Internal/GoldenSpecs.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Aeson.Internal.GoldenSpecs where + +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.ByteString.Lazy hiding (putStrLn) +import Data.Proxy +import Data.Typeable +import GHC.Generics +import Prelude hiding (readFile, writeFile) +import System.Directory +import System.FilePath +import System.Random +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Gen +import Test.QuickCheck.Random + +import Test.Aeson.Internal.RoundtripSpecs + +-- | Allows to obtain tests that will try to ensure that the JSON encoding +-- didn't change unintentionally. To this end 'goldenSpecs' will +-- +-- - write a file @golden.json/TYPENAME.json@ in the current directory +-- containing a number of JSON-encoded sample values, +-- - during subsequent tests it will encode the same sample values again and +-- compare them with the saved golden encodings, +-- - on failure it will create a file @golden.json/TYPENAME.faulty.json@ for +-- easy manual inspection. +-- +-- You can consider putting the golden files under revision control. That way +-- it'll be obvious when JSON encodings change. +goldenSpecs :: (Eq a, Show a, Typeable a, Arbitrary a, ToJSON a, FromJSON a) => + Proxy a -> Spec +goldenSpecs proxy = goldenSpecsWithNote proxy Nothing + +goldenSpecsWithNote :: (Eq a, Show a, Typeable a, Arbitrary a, ToJSON a, FromJSON a) => + Proxy a -> Maybe String -> Spec +goldenSpecsWithNote proxy mNote = do + let goldenFile = mkGoldenFile proxy + note = maybe "" (" " ++) mNote + describe ("JSON encoding of " ++ addBrackets (show (typeRep proxy)) ++ note) $ do + it ("produces the same JSON as is found in " ++ goldenFile) $ do + exists <- doesFileExist goldenFile + if exists + then compareWithGolden proxy goldenFile + else createGoldenfile proxy goldenFile + +mkGoldenFile :: Typeable a => Proxy a -> FilePath +mkGoldenFile proxy = + "golden.json" show (typeRep proxy) <.> "json" + +mkFaultyFile :: Typeable a => Proxy a -> FilePath +mkFaultyFile proxy = + "golden.json" show (typeRep proxy) <.> "faulty" <.> "json" + +createGoldenfile :: forall a . (Show a, Arbitrary a, ToJSON a) => + Proxy a -> FilePath -> IO () +createGoldenfile proxy goldenFile = do + createDirectoryIfMissing True (takeDirectory goldenFile) + seed <- randomIO + samples <- mkRandomSamples proxy seed + writeFile goldenFile (encodePretty samples) + putStrLn $ + "\n" ++ + "WARNING: Running for the first time, not testing anything.\n" ++ + " Created " ++ goldenFile ++ " containing random samples,\n" ++ + " will compare JSON encodings with this from now on.\n" ++ + " Please, consider putting " ++ goldenFile ++ " under version control." + +setSeed :: Int -> Gen a -> Gen a +setSeed seed (MkGen g) = MkGen $ \ _randomSeed size -> + g (mkQCGen seed) size + +compareWithGolden :: forall a . + (Eq a, Show a, Typeable a, Arbitrary a, ToJSON a, FromJSON a) => + Proxy a -> FilePath -> IO () +compareWithGolden proxy goldenFile = do + goldenSeed <- readSeed =<< readFile goldenFile + newSamples <- mkRandomSamples proxy goldenSeed + whenFails (writeComparisonFile newSamples) $ do + goldenSamples :: RandomSamples a <- + either (throwIO . ErrorCall) return =<< + eitherDecode' <$> + readFile goldenFile + newSamples `shouldBe` goldenSamples + where + whenFails :: forall a b . IO b -> IO a -> IO a + whenFails = flip onException + + writeComparisonFile newSamples = do + writeFile (mkFaultyFile proxy) (encodePretty newSamples) + putStrLn $ + "\n" ++ + "INFO: Written the current encodings into " ++ mkFaultyFile proxy ++ "." + +-- reads the seed without looking at the samples +readSeed :: ByteString -> IO Int +readSeed s = case eitherDecode s :: Either String (RandomSamples Value) of + Right samples -> return $ seed samples + Left err -> throwIO $ ErrorCall err + +-- * RandomSamples + +data RandomSamples a + = RandomSamples { + seed :: Int, + samples :: [a] + } + deriving (Eq, Ord, Show, Generic) + +instance FromJSON a => FromJSON (RandomSamples a) + +instance ToJSON a => ToJSON (RandomSamples a) + +mkRandomSamples :: forall a . Arbitrary a => + Proxy a -> Int -> IO (RandomSamples a) +mkRandomSamples Proxy seed = do + let gen :: Gen [a] + gen = setSeed seed $ do + replicateM 200 (arbitrary :: Gen a) + RandomSamples seed <$> generate gen diff --git a/src/Test/Aeson/Internal/RoundtripSpecs.hs b/src/Test/Aeson/Internal/RoundtripSpecs.hs new file mode 100644 --- /dev/null +++ b/src/Test/Aeson/Internal/RoundtripSpecs.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Internal module, use at your own risk. +module Test.Aeson.Internal.RoundtripSpecs where + +import Control.Arrow +import Control.Exception +import qualified Data.Aeson as Aeson +import Data.Aeson as Aeson hiding (encode) +import Data.ByteString.Lazy (ByteString) +import Data.Typeable +import Test.Hspec +import Test.QuickCheck + +-- | Allows to obtain a roundtrip test to check whether values of the given type +-- can be successfully converted to JSON and back. +-- +-- 'roundtripSpecs' will +-- +-- - create random values (using 'Arbitrary'), +-- - convert them into JSON (using 'ToJSON'), +-- - read them back into Haskell (using 'FromJSON') and +-- - make sure that the result is the same as the value it started with +-- (using 'Eq'). +roundtripSpecs :: forall a . + (Typeable a, Eq a, Show a, Arbitrary a, ToJSON a, FromJSON a) => + Proxy a -> Spec +roundtripSpecs proxy = genericAesonRoundtripWithNote proxy Nothing + +genericAesonRoundtripWithNote :: forall a . + (Typeable a, Eq a, Show a, Arbitrary a, ToJSON a, FromJSON a) => + Proxy a -> Maybe String -> Spec +genericAesonRoundtripWithNote proxy mNote = do + let note = maybe "" (" " ++) mNote + describe ("JSON encoding of " ++ addBrackets (show (typeRep proxy)) ++ note) $ do + it "allows to encode values with aeson and read them back" $ do + shouldBeIdentity proxy $ + Aeson.encode >>> aesonDecodeIO + +addBrackets :: String -> String +addBrackets s = + if ' ' `elem` s + then "(" ++ s ++ ")" + else s + +-- | [hspec](http://hspec.github.io/) style combinator to easily write tests +-- that check the a given operation returns the same value it was given, e.g. +-- roundtrip tests. +shouldBeIdentity :: (Eq a, Show a, Arbitrary a) => + Proxy a -> (a -> IO a) -> Property +shouldBeIdentity Proxy function = + property $ \ (a :: a) -> do + function a `shouldReturn` a + +aesonDecodeIO :: FromJSON a => ByteString -> IO a +aesonDecodeIO bs = case eitherDecode bs of + Right a -> return a + Left msg -> throwIO $ ErrorCall + ("aeson couldn't parse value: " ++ msg) diff --git a/src/Test/Aeson/RoundtripSpecs.hs b/src/Test/Aeson/RoundtripSpecs.hs deleted file mode 100644 --- a/src/Test/Aeson/RoundtripSpecs.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.Aeson.RoundtripSpecs ( - genericAesonRoundtrip, - shouldBeIdentity, - - -- * re-exports - Proxy(..), -) where - -import Data.Proxy - -import Test.Aeson.RoundtripSpecs.Internal diff --git a/src/Test/Aeson/RoundtripSpecs/Internal.hs b/src/Test/Aeson/RoundtripSpecs/Internal.hs deleted file mode 100644 --- a/src/Test/Aeson/RoundtripSpecs/Internal.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | Internal module, use at your own risk. -module Test.Aeson.RoundtripSpecs.Internal where - -import Control.Arrow -import Control.Exception -import qualified Data.Aeson as Aeson -import Data.Aeson as Aeson hiding (encode) -import Data.ByteString.Lazy (ByteString) -import Data.Typeable -import Test.Hspec -import Test.QuickCheck - --- | Allows to obtain a roundtrip test to check whether values of the given type --- can be successfully converted to JSON and back. --- --- 'genericAesonRoundtrip' will --- --- - create random values (using 'Arbitrary'), --- - convert them into JSON (using 'ToJSON'), --- - read them back into Haskell (using 'FromJSON') and --- - make sure that the result is the same as the value it started with --- (using 'Eq'). -genericAesonRoundtrip :: forall a . - (Typeable a, Eq a, Show a, Arbitrary a, ToJSON a, FromJSON a) => - Proxy a -> Spec -genericAesonRoundtrip proxy = genericAesonRoundtripWithNote proxy Nothing - -genericAesonRoundtripWithNote :: forall a . - (Typeable a, Eq a, Show a, Arbitrary a, ToJSON a, FromJSON a) => - Proxy a -> Maybe String -> Spec -genericAesonRoundtripWithNote proxy mNote = do - let note = maybe "" (" " ++) mNote - describe ("JSON encoding of " ++ addBrackets (show (typeRep proxy)) ++ note) $ do - it "allows to encode values with aeson and read them back" $ do - shouldBeIdentity proxy $ - Aeson.encode >>> aesonDecodeIO - -addBrackets :: String -> String -addBrackets s = - if ' ' `elem` s - then "(" ++ s ++ ")" - else s - --- | [hspec](http://hspec.github.io/) style combinator to easily write tests --- that check the a given operation returns the same value it was given, e.g. --- roundtrip tests. -shouldBeIdentity :: (Eq a, Show a, Arbitrary a) => - Proxy a -> (a -> IO a) -> Property -shouldBeIdentity Proxy function = - property $ \ (a :: a) -> do - function a `shouldReturn` a - -aesonDecodeIO :: FromJSON a => ByteString -> IO a -aesonDecodeIO bs = case eitherDecode bs of - Right a -> return a - Left msg -> throwIO $ ErrorCall - ("aeson couldn't parse value: " ++ msg) diff --git a/test/DoctestSpec.hs b/test/DoctestSpec.hs --- a/test/DoctestSpec.hs +++ b/test/DoctestSpec.hs @@ -1,10 +1,15 @@ module DoctestSpec where +import System.Directory +import System.FilePath import Test.DocTest import Test.Hspec +import Test.Mockery.Directory spec :: Spec spec = do it "doctest" $ do - doctest ["src/Servant/Aeson/RoundtripSpecs.hs"] + dir <- getCurrentDirectory + inTempDirectory $ do + doctest [dir "src/Servant/Aeson/GenericSpecs.hs"] diff --git a/test/Servant/Aeson/GoldenSpecsSpec.hs b/test/Servant/Aeson/GoldenSpecsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Aeson/GoldenSpecsSpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} + +module Servant.Aeson.GoldenSpecsSpec where + +import Data.Proxy +import Servant.API +import System.Directory +import Test.Hspec +import Test.Hspec.Core.Runner +import Test.Mockery.Directory +import Test.Utils + +import Servant.Aeson.GenericSpecs + +spec :: Spec +spec = do + describe "apiGoldenSpecs" $ do + it "writes files for used types" $ do + inTempDirectory $ do + _ <- hspecSilently $ apiGoldenSpecs (Proxy :: Proxy (Get '[JSON] Bool)) + doesFileExist "golden.json/Bool.json" `shouldReturn` True + + it "raises errors for non-matching golden files" $ do + inTempDirectory $ do + createDirectoryIfMissing True "golden.json" + writeFile "golden.json/Bool.json" "foo" + apiGoldenSpecs (Proxy :: Proxy (Get '[JSON] Bool)) `shouldTestAs` + Summary 1 1 diff --git a/test/Servant/Aeson/RoundtripSpecsSpec.hs b/test/Servant/Aeson/RoundtripSpecsSpec.hs --- a/test/Servant/Aeson/RoundtripSpecsSpec.hs +++ b/test/Servant/Aeson/RoundtripSpecsSpec.hs @@ -3,15 +3,19 @@ module Servant.Aeson.RoundtripSpecsSpec where +import Data.List import Data.Typeable import Servant.API +import System.Directory import System.IO import System.IO.Temp import Test.Hspec import Test.Hspec.Core.Runner +import Test.Mockery.Directory -import Servant.Aeson.RoundtripSpecs +import Servant.Aeson.GenericSpecs import Test.Aeson.RoundtripSpecsSpec +import Test.Utils -- ignores the Summary hspecOutput :: Spec -> IO String @@ -26,23 +30,38 @@ spec :: Spec spec = do - describe "roundtripSpecs" $ do + describe "apiRoundtripSpecs" $ do it "detects failures in types from ReqBody" $ do - roundtripSpecs reqBodyFailApi `shouldTestAs` + apiRoundtripSpecs reqBodyFailApi `shouldTestAs` Summary 2 1 it "detects failures in types from Get" $ do - roundtripSpecs getFailApi `shouldTestAs` + apiRoundtripSpecs getFailApi `shouldTestAs` Summary 1 1 context "when it finds a list of something" $ do it "returns only the element type" $ do - usedTypes getBoolList `shouldBe` [boolRep] + usedTypes getListOfBool `shouldBe` [boolRep] it "mentions that the type was wrapped in a list" $ do - output <- hspecOutput $ roundtripSpecs getBoolList + output <- hspecOutput $ apiRoundtripSpecs getListOfBool output `shouldContain` "(as element-type in [])" + context "when it finds a Maybe" $ do + it "returns only the element type" $ do + usedTypes (Proxy :: Proxy (Get '[JSON] (Maybe Bool))) + `shouldBe` [boolRep] + + context "when it finds ()" $ do + it "does not return anything" $ do + usedTypes (Proxy :: Proxy (Get '[JSON] ())) + `shouldBe` [] + + it "does not write any files" $ do + inTempDirectory $ do + _ <- hspecSilently $ apiRoundtripSpecs reqBodyFailApi + sort <$> getDirectoryContents "." `shouldReturn` [".", ".."] + describe "usedTypes" $ do it "extracts types from ReqBody" $ do usedTypes reqBodyFailApi `shouldMatchList` @@ -71,8 +90,8 @@ getFailApi :: Proxy (Get '[JSON] FaultyRoundtrip) getFailApi = Proxy -getBoolList :: Proxy (Get '[JSON] [Bool]) -getBoolList = Proxy +getListOfBool :: Proxy (Get '[JSON] [Bool]) +getListOfBool = Proxy doubleTypesApi :: Proxy (ReqBody '[JSON] Bool :> Get '[JSON] Bool) doubleTypesApi = Proxy diff --git a/test/Test/Aeson/GoldenSpecsSpec.hs b/test/Test/Aeson/GoldenSpecsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Aeson/GoldenSpecsSpec.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Aeson.GoldenSpecsSpec where + +import Control.Exception +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.ByteString.Lazy as DBL (readFile, writeFile) +import Data.List +import Data.Proxy +import Data.String.Conversions +import Data.Text (Text) +import Prelude hiding (readFile, writeFile, putStrLn) +import System.Directory +import Test.Hspec +import Test.Mockery.Directory +import Test.QuickCheck.Instances () + +import Test.Aeson.Internal.GoldenSpecs +import Test.Utils + +textP :: Proxy Text +textP = Proxy + +spec :: Spec +spec = do + describe "goldenSpecs" $ do + around_ inTempDirectory $ do + context "when invoked for the first time" $ do + it "creates passing tests" $ do + goldenSpecs textP `shouldProduceFailures` 0 + + it "writes a golden file" $ do + _ <- hspecSilently $ goldenSpecs textP + doesFileExist "golden.json/Text.json" `shouldReturn` True + + it "writes a seed and a list of values into a golden file" $ do + _ <- hspecSilently $ goldenSpecs textP + contents <- readFile "golden.json/Text.json" + case decode' contents :: Maybe (RandomSamples String) of + Nothing -> throwIO $ ErrorCall "decoding error" + Just _ -> return () + + it "warns about not testing anything" $ do + (_, output) <- hspecSilently $ goldenSpecs textP + output `shouldContain` + "WARNING: Running for the first time, not testing anything" + + it "writes JSON pretty-printed" $ do + _ <- hspecSilently $ goldenSpecs textP + samplesString <- readFile "golden.json/Text.json" + samples :: RandomSamples Text <- + either (throwIO . ErrorCall) return + (eitherDecode samplesString) + let prefix = unlines $ + "{" : + (" \"seed\": " ++ show (seed samples) ++ ",") : + " \"samples\": [" : + [] + cs samplesString `shouldStartWith` prefix + + context "when invoked for the second time" $ do + it "creates passing tests for correct encodings" $ do + _ <- hspecSilently $ goldenSpecs textP + goldenSpecs textP `shouldProduceFailures` 0 + + it "creates failing tests for incorrect encodings of RandomSamples" $ do + createDirectoryIfMissing True "golden.json" + writeFile "golden.json/Text.json" "foo" + goldenSpecs textP `shouldProduceFailures` 1 + + context "when encodings changed" $ do + it "creates failing tests for incorrect encodings of elements" $ do + createGoldenfile (Proxy :: Proxy Int) "golden.json/Text.json" + goldenSpecs textP `shouldProduceFailures` 1 + + let createFaultySamples = do + createDirectoryIfMissing True "golden.json" + let faultySamples :: RandomSamples Text + faultySamples = RandomSamples 42 (take 200 (cycle ["foo", "bar"])) + writeFile "golden.json/Text.json" (encode faultySamples) + + it "creates failing tests for correct encodings of wrong values" $ do + createFaultySamples + goldenSpecs textP `shouldProduceFailures` 1 + + it "writes a new file for easy manual comparison" $ do + createDirectoryIfMissing True "golden.json" + let faultySamples :: RandomSamples Int + faultySamples = RandomSamples 42 (take 200 [1 ..]) + writeFile "golden.json/Text.json" (encode faultySamples) + _ <- hspecSilently $ goldenSpecs textP + + testSeedSamples <- mkRandomSamples textP 42 + readFile "golden.json/Text.faulty.json" `shouldReturn` + encodePretty testSeedSamples + + it "mentions the created file in the output" $ do + createFaultySamples + (_, output) <- hspecSilently $ goldenSpecs textP + output `shouldContain` "golden.json/Text.faulty.json" diff --git a/test/Test/Aeson/RoundtripSpecsSpec.hs b/test/Test/Aeson/RoundtripSpecsSpec.hs --- a/test/Test/Aeson/RoundtripSpecsSpec.hs +++ b/test/Test/Aeson/RoundtripSpecsSpec.hs @@ -7,41 +7,25 @@ import Control.Applicative import Data.Aeson import GHC.Generics -import System.IO -import System.IO.Temp import Test.Hspec import Test.Hspec.Core.Runner import Test.QuickCheck -import Test.Aeson.RoundtripSpecs - -hspecSilently :: Spec -> IO Summary -hspecSilently s = do - withSystemTempFile "ghcjs-hspec-jsval-aeson" $ \ path handle -> do - hClose handle - let silentConfig :: Test.Hspec.Core.Runner.Config - silentConfig = defaultConfig{ - configOutputFile = Right path - } - hspecWithResult silentConfig s - -shouldTestAs :: Spec -> Summary -> IO () -shouldTestAs spec expected = do - summary <- hspecSilently spec - summary `shouldBe` expected +import Test.Aeson.GenericSpecs +import Test.Utils spec :: Spec spec = do - describe "genericAesonRoundtrip" $ do + describe "roundtripSpecs" $ do it "detects incompatible json encodings" $ do - genericAesonRoundtrip faultyRoundtripProxy `shouldTestAs` Summary 1 1 + roundtripSpecs faultyRoundtripProxy `shouldTestAs` Summary 1 1 context "when used with compatible encodings" $ do it "creates passing tests" $ do - genericAesonRoundtrip correctProxy `shouldTestAs` Summary 1 0 + roundtripSpecs correctProxy `shouldTestAs` Summary 1 0 it "creates passing tests for sum types" $ do - genericAesonRoundtrip correctSumProxy `shouldTestAs` Summary 1 0 + roundtripSpecs correctSumProxy `shouldTestAs` Summary 1 0 -- | Type where roundtrips don't work. data FaultyRoundtrip diff --git a/test/Test/Utils.hs b/test/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Test/Utils.hs @@ -0,0 +1,37 @@ + +module Test.Utils where + +import Control.Monad +import Data.Tuple +import System.IO.Silently +import Test.Hspec +import Test.Hspec.Core.Runner + +hspecSilently :: Spec -> IO (Summary, String) +hspecSilently s = do + swap <$> capture (hspecResult s) + +shouldTestAs :: Spec -> Summary -> IO () +shouldTestAs spec expected = do + (summary, output) <- hspecSilently spec + when (summary /= expected) $ + expectationFailure $ + "spec didn't yield the expected summary:\n" ++ + " expected: " ++ show expected ++ "\n" ++ + " got: " ++ show summary ++ "\n" ++ + "output of the test-suite:\n" ++ + indent output + +shouldProduceFailures :: Spec -> Int -> IO () +shouldProduceFailures spec expected = do + (summary, output) <- hspecSilently spec + when (summaryFailures summary /= expected) $ + expectationFailure $ + "spec didn't yield the expected number of failures summary:\n" ++ + " expected: " ++ show expected ++ "\n" ++ + " got: " ++ show (summaryFailures summary) ++ "\n" ++ + "output of the test-suite:\n" ++ + indent output + +indent :: String -> String +indent = unlines . map (" " ++ ) . lines