From f95d2fcadcb858c7a759cc8f69fb5ba90749ceef Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Sun, 6 Dec 2020 15:31:43 +0100 Subject: [PATCH] Drop Mime{,Un}Render instances that do not shrink head. --- servant-docs/example/greet.hs | 3 +++ servant-docs/test/Servant/DocsSpec.hs | 3 +++ servant-server/example/greet.hs | 4 +++ .../test/Servant/ArbitraryMonadServerSpec.hs | 13 ++++++++-- servant-server/test/Servant/HoistSpec.hs | 10 ++++++- .../test/Servant/Server/ErrorSpec.hs | 3 +++ .../test/Servant/Server/UsingContextSpec.hs | 10 +++++-- servant-server/test/Servant/ServerSpec.hs | 4 +++ servant/servant.cabal | 1 + servant/src/Servant/API/ContentTypes.hs | 26 ++----------------- servant/test/Servant/API/ContentTypesSpec.hs | 19 ++++++++++++++ 11 files changed, 67 insertions(+), 29 deletions(-) diff --git a/servant-docs/example/greet.hs b/servant-docs/example/greet.hs index ec36c7ca..0a196f2f 100644 --- a/servant-docs/example/greet.hs +++ b/servant-docs/example/greet.hs @@ -30,6 +30,9 @@ instance ToJSON Greet instance MimeRender PlainText Greet where mimeRender Proxy (Greet s) = "\"" <> cs s <> "\"" +instance MimeRender JSON Greet where + mimeRender Proxy = encode + -- We add some useful annotations to our captures, -- query parameters and request body to make the docs -- really helpful. diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 5da5ff4d..9d80e1ff 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -216,3 +216,6 @@ compareWith f msg x y = unless (f x y) $ assertFailure $ golden :: TestName -> FilePath -> String -> TestTreeM () golden n fp contents = TestTreeM $ tell [ goldenVsString n fp (return (cs contents)) ] + +instance ToJSON a => MimeRender JSON a where + mimeRender _ = encode diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index e354351f..64816813 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -26,6 +28,8 @@ newtype Greet = Greet { _msg :: Text } instance FromJSON Greet instance ToJSON Greet +instance ToJSON a => MimeRender JSON a where mimeRender _ = encode + -- API specification type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON diff --git a/servant-server/test/Servant/ArbitraryMonadServerSpec.hs b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs index d492250b..52089feb 100644 --- a/servant-server/test/Servant/ArbitraryMonadServerSpec.hs +++ b/servant-server/test/Servant/ArbitraryMonadServerSpec.hs @@ -1,9 +1,14 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} module Servant.ArbitraryMonadServerSpec where import Control.Monad.Reader +import Data.Aeson + (encode) import Data.Functor.Identity import Data.Proxy import Servant.API @@ -60,3 +65,7 @@ enterSpec = describe "Enter" $ do with (return (serve combinedAPI combinedReaderServer)) $ do it "allows combnation of enters" $ do get "bool" `shouldRespondWith` "true" + +instance MimeRender JSON Bool where mimeRender _ = encode +instance MimeRender JSON Int where mimeRender _ = encode +instance MimeRender JSON String where mimeRender _ = encode diff --git a/servant-server/test/Servant/HoistSpec.hs b/servant-server/test/Servant/HoistSpec.hs index e29387dc..75f9bf34 100644 --- a/servant-server/test/Servant/HoistSpec.hs +++ b/servant-server/test/Servant/HoistSpec.hs @@ -1,7 +1,13 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} module Servant.HoistSpec where +import Data.Aeson + (ToJSON, encode) import Test.Hspec (Spec) @@ -31,6 +37,8 @@ f = id server' :: App Int :<|> (String -> App Bool) server' = hoistServer api f server +instance ToJSON a => MimeRender JSON a where mimeRender _ = encode + ------------------------------------------------------------------------------- -- Spec ------------------------------------------------------------------------------- diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 72251b21..1809c931 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -360,4 +360,7 @@ instance MimeUnrender PlainText Int where instance MimeRender PlainText Int where mimeRender _ = BCL.pack . show + +instance MimeRender JSON Integer where mimeRender _ = encode +instance MimeRender JSON Int where mimeRender _ = encode -- }}} diff --git a/servant-server/test/Servant/Server/UsingContextSpec.hs b/servant-server/test/Servant/Server/UsingContextSpec.hs index 5258f190..c174e340 100644 --- a/servant-server/test/Servant/Server/UsingContextSpec.hs +++ b/servant-server/test/Servant/Server/UsingContextSpec.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} module Servant.Server.UsingContextSpec where +import Data.Aeson + (encode) import Network.Wai import Test.Hspec (Spec, describe, it) @@ -20,6 +24,8 @@ spec = do spec3 spec4 +instance MimeRender JSON String where mimeRender _ = encode + -- * API type OneEntryAPI = diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e3dec48e..5d91cf8b 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -50,6 +51,7 @@ import Servant.API BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header, Headers, HttpVersion, IsSecure (..), JSON, Lenient, + MimeRender (..), NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, @@ -106,6 +108,8 @@ spec = do -- * verbSpec {{{ ------------------------------------------------------------------------------ +instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where mimeRender _ = encode + type VerbApi method status = Verb method status '[JSON] Person :<|> "noContent" :> NoContentVerb method diff --git a/servant/servant.cabal b/servant/servant.cabal index 22f9dba7..6ffafcf5 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -154,6 +154,7 @@ test-suite spec , base-compat , aeson , bytestring + , http-api-data , http-media , mtl , servant diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index d6d200ad..faa55cf3 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -74,7 +74,7 @@ import Control.Monad.Compat import Control.DeepSeq (NFData) import Data.Aeson - (FromJSON (..), ToJSON (..), encode) + (FromJSON (..)) import Data.Aeson.Parser (value) import Data.Aeson.Types @@ -102,7 +102,7 @@ import qualified Network.HTTP.Media as M import Prelude () import Prelude.Compat import Web.FormUrlEncoded - (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm) + (FromForm, urlDecodeAsForm) -- * Provided content types data JSON deriving Typeable @@ -327,18 +327,6 @@ instance ( MimeUnrender ctyp a -------------------------------------------------------------------------- -- * MimeRender Instances --- | `encode` -instance {-# OVERLAPPABLE #-} - ToJSON a => MimeRender JSON a where - mimeRender _ = encode - --- | @urlEncodeAsForm@ --- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only --- holds if every element of x is non-null (i.e., not @("", "")@) -instance {-# OVERLAPPABLE #-} - ToForm a => MimeRender FormUrlEncoded a where - mimeRender _ = urlEncodeAsForm - -- | `TextL.encodeUtf8` instance MimeRender PlainText TextL.Text where mimeRender _ = TextL.encodeUtf8 @@ -388,16 +376,6 @@ eitherDecodeLenient input = <* skipSpace <* (endOfInput "trailing junk after valid JSON") --- | `eitherDecode` -instance FromJSON a => MimeUnrender JSON a where - mimeUnrender _ = eitherDecodeLenient - --- | @urlDecodeAsForm@ --- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only --- holds if every element of x is non-null (i.e., not @("", "")@) -instance FromForm a => MimeUnrender FormUrlEncoded a where - mimeUnrender _ = left TextS.unpack . urlDecodeAsForm - -- | @left show . TextL.decodeUtf8'@ instance MimeUnrender PlainText TextL.Text where mimeUnrender _ = left show . TextL.decodeUtf8' diff --git a/servant/test/Servant/API/ContentTypesSpec.hs b/servant/test/Servant/API/ContentTypesSpec.hs index 1a7d4d1d..8d554480 100644 --- a/servant/test/Servant/API/ContentTypesSpec.hs +++ b/servant/test/Servant/API/ContentTypesSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} @@ -39,6 +40,8 @@ import Test.QuickCheck import "quickcheck-instances" Test.QuickCheck.Instances () import Text.Read (readMaybe) +import Web.FormUrlEncoded + (ToForm, urlEncodeAsForm) import Servant.API.ContentTypes @@ -271,3 +274,19 @@ addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h) where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f) cont "" = new cont old = old `append` ", " `append` new + +-- | `encode` +-- +-- This instance is not provided with the library to avoid unsolvable ambiguous instance +-- problems. Example: @instance MimeRender a => MimeRender (WithStatus n a)@ +instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where + mimeRender _ = encode + +-- | @urlEncodeAsForm@ +-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only +-- holds if every element of x is non-null (i.e., not @("", "")@) +-- +-- This instance is not provided with the library to avoid unsolvable ambiguous instance +-- problems. +instance {-# OVERLAPPABLE #-} ToForm a => MimeRender FormUrlEncoded a where + mimeRender _ = urlEncodeAsForm