diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,26 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. +0.20 +---- + +- Headers support in UVerb responses [#1570](https://github.com/haskell-servant/servant/issues/1570) [#1571](https://github.com/haskell-servant/servant/pull/1571) +- Generalize type of `Servant.Types.SourceT.source` to any foldable [#1593](https://github.com/haskell-servant/servant/pull/1593) +- Make `Mime(Un)Render PlainText String` instances encode/decode UTF-8 [#1645](https://github.com/haskell-servant/servant/issues/1645) +- Add HasStatus instance for Headers (that defers StatusOf to underlying value) [#1649](https://github.com/haskell-servant/servant/pull/1649) +- Make fromSourceIO run in IO [#1661](https://github.com/haskell-servant/servant/pull/1661) + + Some streaming abstractions, like io-streams, require stateful + initialization. Since all actual call sites of `fromSourceIO` + are in a context where `IO` actions can be executed, these + streaming sources can be accomodated by having letting + `fromSourceIO` run in `IO`. + + To migrate your existing `FromSourceIO` instance, simply put + a `pure`/`return` in front of it. + +- Fix the handling of multiple headers with the same name. [#1666](https://github.com/haskell-servant/servant/pull/1666) + 0.19.1 ------ diff --git a/servant.cabal b/servant.cabal --- a/servant.cabal +++ b/servant.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: servant -version: 0.19.1 +version: 0.20 synopsis: A family of combinators for defining webservices APIs category: Servant, Web @@ -20,7 +20,7 @@ copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple -tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 +tested-with: GHC==8.6.5, GHC==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4 , GHCJS ==8.6.0.1 extra-source-files: @@ -62,6 +62,7 @@ Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext + Servant.API.WithResource -- Types exposed-modules: @@ -80,28 +81,28 @@ -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.9 && < 4.18 + base >= 4.9 && < 4.19 , bytestring >= 0.10.8.1 && < 0.12 , constraints >= 0.2 - , mtl >= 2.2.2 && < 2.3 + , mtl ^>= 2.2.2 || ^>= 2.3.1 , sop-core >= 0.4.0.0 && < 0.6 - , transformers >= 0.5.2.0 && < 0.6 + , transformers >= 0.5.2.0 && < 0.7 , text >= 1.2.3.0 && < 2.1 -- We depend (heavily) on the API of these packages: -- i.e. re-export, or allow using without direct dependency build-depends: - http-api-data >= 0.4.1 && < 0.5.1 - , singleton-bool >= 0.1.4 && < 0.1.7 + http-api-data >= 0.4.1 && < 0.6 + , singleton-bool >= 0.1.4 && < 0.2 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - base-compat >= 0.10.5 && < 0.13 + base-compat >= 0.10.5 && < 0.14 , aeson >= 1.4.1.0 && < 3 , attoparsec >= 0.13.2.2 && < 0.15 - , bifunctors >= 5.5.3 && < 5.6 + , bifunctors >= 5.5.3 && < 5.7 , case-insensitive >= 1.2.0.11 && < 1.3 , deepseq >= 1.4.2.0 && < 1.5 , http-media >= 0.7.1.3 && < 0.9 @@ -166,9 +167,9 @@ -- Additional dependencies build-depends: - hspec >= 2.6.0 && < 2.10 + hspec >= 2.6.0 && < 2.11 , QuickCheck >= 2.12.6.1 && < 2.15 , quickcheck-instances >= 0.3.19 && < 0.4 build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && < 2.10 + hspec-discover:hspec-discover >= 2.6.0 && < 2.11 diff --git a/src/Servant/API.hs b/src/Servant/API.hs --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -31,6 +31,8 @@ -- | Access the location for arbitrary data to be shared by applications and middleware module Servant.API.WithNamedContext, -- | Access context entries in combinators in servant-server + module Servant.API.WithResource, + -- | Access a managed resource scoped to a single request -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, @@ -101,21 +103,23 @@ (AuthProtect) import Servant.API.Fragment (Fragment) +import Servant.API.Generic + (AsApi, GServantProduct, GenericMode ((:-)), GenericServant, + ToServant, ToServantApi, fromServant, genericApi, toServant) import Servant.API.Header (Header, Header') -import Servant.API.Generic - (GenericMode ((:-)), AsApi, ToServant, ToServantApi, GServantProduct, - GenericServant, fromServant, toServant, genericApi) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) import Servant.API.Modifiers (Lenient, Optional, Required, Strict) +import Servant.API.NamedRoutes + (NamedRoutes) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParam', QueryParams) import Servant.API.Raw - (Raw) + (Raw, RawM) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody @@ -137,8 +141,6 @@ Unique, WithStatus (..), inject, statusOf) import Servant.API.Vault (Vault) -import Servant.API.NamedRoutes - (NamedRoutes) import Servant.API.Verbs (Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, @@ -150,6 +152,8 @@ ReflectMethod (reflectMethod), StdMethod (..), Verb) import Servant.API.WithNamedContext (WithNamedContext) +import Servant.API.WithResource + (WithResource) import Servant.Links (HasLink (..), IsElem, IsElem', Link, URI (..), safeLink) import Web.HttpApiData diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -82,10 +82,11 @@ (parseEither) import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, skipSpace, ()) +import Data.Bifunctor + (bimap) import qualified Data.ByteString as BS import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) -import qualified Data.ByteString.Lazy.Char8 as BC import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) @@ -350,7 +351,7 @@ -- | @BC.pack@ instance MimeRender PlainText String where - mimeRender _ = BC.pack + mimeRender _ = TextL.encodeUtf8 . TextL.pack -- | @id@ instance MimeRender OctetStream ByteString where @@ -409,7 +410,7 @@ -- | @Right . BC.unpack@ instance MimeUnrender PlainText String where - mimeUnrender _ = Right . BC.unpack + mimeUnrender _ = bimap show TextL.unpack . TextL.decodeUtf8' -- | @Right . id@ instance MimeUnrender OctetStream ByteString where diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -15,3 +15,6 @@ -- -- to serve static files stored in a particular directory on your filesystem data Raw deriving Typeable + +-- | Variant of 'Raw' that lets you access the underlying monadic context to process the request. +data RawM deriving Typeable diff --git a/src/Servant/API/ResponseHeaders.hs b/src/Servant/API/ResponseHeaders.hs --- a/src/Servant/API/ResponseHeaders.hs +++ b/src/Servant/API/ResponseHeaders.hs @@ -8,6 +8,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} @@ -38,6 +39,7 @@ import Data.ByteString.Char8 as BS (ByteString, init, pack, unlines) import qualified Data.CaseInsensitive as CI +import qualified Data.List as L import Data.Proxy import Data.Typeable (Typeable) @@ -51,6 +53,9 @@ import Prelude.Compat import Servant.API.Header (Header) +import Servant.API.UVerb.Union +import qualified Data.SOP.BasicFunctors as SOP +import qualified Data.SOP.NS as SOP -- | Response Header objects. You should never need to construct one directly. -- Instead, use 'addOptionalHeader'. @@ -93,24 +98,21 @@ class BuildHeadersTo hs where buildHeadersTo :: [HTTP.Header] -> HList hs - -- ^ Note: if there are multiple occurrences of a header in the argument, - -- the values are interspersed with commas before deserialization (see - -- ) instance {-# OVERLAPPING #-} BuildHeadersTo '[] where buildHeadersTo _ = HNil +-- The current implementation does not manipulate HTTP header field lines in any way, +-- like merging field lines with the same field name in a single line. instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h ) => BuildHeadersTo (Header h v ': xs) where - buildHeadersTo headers = - let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) - matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers - in case matching of - [] -> MissingHeader `HCons` buildHeadersTo headers - xs -> case parseHeader (BS.init $ BS.unlines xs) of - Left _err -> UndecodableHeader (BS.init $ BS.unlines xs) - `HCons` buildHeadersTo headers - Right h -> Header h `HCons` buildHeadersTo headers + buildHeadersTo headers = case L.find wantedHeader headers of + Nothing -> MissingHeader `HCons` buildHeadersTo headers + Just header@(_, val) -> case parseHeader val of + Left _err -> UndecodableHeader val `HCons` buildHeadersTo (L.delete header headers) + Right h -> Header h `HCons` buildHeadersTo (L.delete header headers) + where wantedHeader (h, _) = h == wantedHeaderName + wantedHeaderName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) -- * Getting headers @@ -170,13 +172,32 @@ => AddHeader h v a new where addOptionalHeader hdr resp = Headers resp (HCons hdr HNil) +-- Instances to decorate all responses in a 'Union' with headers. The functional +-- dependencies force us to consider singleton lists as the base case in the +-- recursion (it is impossible to determine h and v otherwise from old / new +-- responses if the list is empty). +instance (AddHeader h v old new) => AddHeader h v (Union '[old]) (Union '[new]) where + addOptionalHeader hdr resp = + SOP.Z $ SOP.I $ addOptionalHeader hdr $ SOP.unI $ SOP.unZ $ resp + +instance + ( AddHeader h v old new, AddHeader h v (Union oldrest) (Union newrest) + -- This ensures that the remainder of the response list is _not_ empty + -- It is necessary to prevent the two instances for union types from + -- overlapping. + , oldrest ~ (a ': as), newrest ~ (b ': bs)) + => AddHeader h v (Union (old ': (a ': as))) (Union (new ': (b ': bs))) where + addOptionalHeader hdr resp = case resp of + SOP.Z (SOP.I rHead) -> SOP.Z $ SOP.I $ addOptionalHeader hdr rHead + SOP.S rOthers -> SOP.S $ addOptionalHeader hdr rOthers + -- | @addHeader@ adds a header to a response. Note that it changes the type of -- the value in the following ways: -- -- 1. A simple value is wrapped in "Headers '[hdr]": -- --- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; --- >>> getHeaders example1 +-- >>> let example0 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; +-- >>> getHeaders example0 -- [("someheader","5")] -- -- 2. A value that already has a header has its new header *prepended* to the diff --git a/src/Servant/API/Stream.hs b/src/Servant/API/Stream.hs --- a/src/Servant/API/Stream.hs +++ b/src/Servant/API/Stream.hs @@ -113,10 +113,10 @@ -- Pipe, etc. By implementing this class, all such streaming abstractions can -- be used directly on the client side for talking to streaming endpoints. class FromSourceIO chunk a | a -> chunk where - fromSourceIO :: SourceIO chunk -> a + fromSourceIO :: SourceIO chunk -> IO a instance MonadIO m => FromSourceIO a (SourceT m a) where - fromSourceIO = sourceFromSourceIO + fromSourceIO = return . sourceFromSourceIO sourceFromSourceIO :: forall m a. MonadIO m => SourceT IO a -> SourceT m a sourceFromSourceIO src = diff --git a/src/Servant/API/TypeErrors.hs b/src/Servant/API/TypeErrors.hs --- a/src/Servant/API/TypeErrors.hs +++ b/src/Servant/API/TypeErrors.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -12,9 +13,11 @@ PartialApplication, NoInstanceFor, NoInstanceForSub, + ErrorIfNoGeneric, ) where import Data.Kind +import GHC.Generics (Generic(..)) import GHC.TypeLits -- | No instance exists for @tycls (expr :> ...)@ because @@ -38,3 +41,19 @@ type family Arity' (ty :: k) :: Nat where Arity' (_ -> ty) = 1 + Arity' ty Arity' _ = 0 + +-- see https://blog.csongor.co.uk/report-stuck-families/ +type ErrorIfNoGeneric routes = Break (NoGeneric routes :: Type) (Rep (routes ())) + +data T1 a + +type family Break err a :: Constraint where + Break _ T1 = ((), ()) + Break _ a = () + +type family NoGeneric (routes :: Type -> Type) where + NoGeneric routes = TypeError + ( 'Text "Named routes require a " + ':<>: 'ShowType Generic ':<>: 'Text " instance for " + ':<>: 'ShowType routes + ) diff --git a/src/Servant/API/UVerb.hs b/src/Servant/API/UVerb.hs --- a/src/Servant/API/UVerb.hs +++ b/src/Servant/API/UVerb.hs @@ -38,6 +38,7 @@ import Network.HTTP.Types (Status, StdMethod) import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender)) import Servant.API.Status (KnownStatus, statusVal) +import Servant.API.ResponseHeaders (Headers) import Servant.API.UVerb.Union class KnownStatus (StatusOf a) => HasStatus (a :: *) where @@ -86,6 +87,8 @@ instance KnownStatus n => HasStatus (WithStatus n a) where type StatusOf (WithStatus n a) = n +instance HasStatus a => HasStatus (Headers ls a) where + type StatusOf (Headers ls a) = StatusOf a -- | A variant of 'Verb' that can have any of a number of response values and status codes. -- diff --git a/src/Servant/API/UVerb/Union.hs b/src/Servant/API/UVerb/Union.hs --- a/src/Servant/API/UVerb/Union.hs +++ b/src/Servant/API/UVerb/Union.hs @@ -111,8 +111,8 @@ eject (Z _) = Nothing eject (S ns) = eject ns --- | Check whether @a@ is in list. This will throw nice errors if the element is not in the --- list, or if there is a duplicate in the list. +-- | Check whether @a@ is in given type-level list. +-- This will throw a nice error if the element is not in the list. type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where CheckElemIsMember a as = If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as)) @@ -128,10 +128,12 @@ ':$$: 'Text " " ':<>: 'ShowType rs type family Elem (x :: k) (xs :: [k]) :: Bool where + Elem x (x ': _) = 'True + Elem x (_ ': xs) = Elem x xs Elem _ '[] = 'False - Elem x (x' ': xs) = - If (x == x') 'True (Elem x xs) +-- | Check whether all values in a type-level list are distinct. +-- This will throw a nice error if there are any duplicate elements in the list. type family Unique xs :: Constraint where Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs)) diff --git a/src/Servant/API/WithResource.hs b/src/Servant/API/WithResource.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/WithResource.hs @@ -0,0 +1,3 @@ +module Servant.API.WithResource (WithResource) where + +data WithResource res diff --git a/src/Servant/Links.hs b/src/Servant/Links.hs --- a/src/Servant/Links.hs +++ b/src/Servant/Links.hs @@ -175,7 +175,7 @@ import Servant.API.QueryParam (QueryFlag, QueryParam', QueryParams) import Servant.API.Raw - (Raw) + (Raw, RawM) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody @@ -193,6 +193,8 @@ (Verb, NoContentVerb) import Servant.API.WithNamedContext (WithNamedContext) +import Servant.API.WithResource + (WithResource) import Web.HttpApiData import Data.Kind (Type) @@ -558,6 +560,10 @@ type MkLink (WithNamedContext name context sub) a = MkLink sub a toLink toA _ = toLink toA (Proxy :: Proxy sub) +instance HasLink sub => HasLink (WithResource res :> sub) where + type MkLink (WithResource res :> sub) a = MkLink sub a + toLink toA _ = toLink toA (Proxy :: Proxy sub) + instance HasLink sub => HasLink (RemoteHost :> sub) where type MkLink (RemoteHost :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) @@ -583,6 +589,10 @@ type MkLink Raw a = a toLink toA _ = toA +instance HasLink RawM where + type MkLink RawM a = a + toLink toA _ = toA + instance HasLink (Stream m status fr ct a) where type MkLink (Stream m status fr ct a) r = r toLink toA _ = toA @@ -607,6 +617,7 @@ instance ( HasLink (ToServantApi routes) , forall a. GLink routes a + , ErrorIfNoGeneric routes ) => HasLink (NamedRoutes routes) where type MkLink (NamedRoutes routes) a = routes (AsLink a) diff --git a/src/Servant/Test/ComprehensiveAPI.hs b/src/Servant/Test/ComprehensiveAPI.hs --- a/src/Servant/Test/ComprehensiveAPI.hs +++ b/src/Servant/Test/ComprehensiveAPI.hs @@ -72,6 +72,7 @@ :<|> "description" :> Description "foo" :> GET :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET) :<|> "fragment" :> Fragment Int :> GET + :<|> "resource" :> WithResource Int :> GET :<|> endpoint type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint diff --git a/src/Servant/Types/SourceT.hs b/src/Servant/Types/SourceT.hs --- a/src/Servant/Types/SourceT.hs +++ b/src/Servant/Types/SourceT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} @@ -24,7 +25,7 @@ import qualified Test.QuickCheck as QC -- $setup --- >>> :set -XOverloadedStrings +-- >>> import Data.String (fromString) -- >>> import Control.Monad.Except (runExcept) -- >>> import Data.Foldable (toList) -- >>> import qualified Data.Attoparsec.ByteString.Char8 as A8 @@ -66,7 +67,7 @@ instance Functor m => Functor (SourceT m) where fmap f = mapStepT (fmap f) --- | >>> toList (source [1..10]) +-- | >>> toList (source [1::Int .. 10]) -- [1,2,3,4,5,6,7,8,9,10] -- instance Identity ~ m => Foldable (SourceT m) where @@ -151,11 +152,17 @@ instance (Applicative m, Show1 m, Show a) => Show (StepT m a) where showsPrec = showsPrec1 +#if !MIN_VERSION_transformers(0,6,0) +-- Since transformers-0.6, MonadTrans only works on Monads. +-- StepT isn't necesssarily a monad. It doesn't have the Monad instance. +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/19922 + -- | >>> lift [1,2,3] :: StepT [] Int -- Effect [Yield 1 Stop,Yield 2 Stop,Yield 3 Stop] -- instance MonadTrans StepT where lift = Effect . fmap (`Yield` Stop) +#endif instance MFunctor StepT where hoist f = go where @@ -212,7 +219,7 @@ -- >>> source "foo" :: SourceT Identity Char -- fromStepT (Effect (Identity (Yield 'f' (Yield 'o' (Yield 'o' Stop))))) -- -source :: [a] -> SourceT m a +source :: Foldable f => f a -> SourceT m a source = fromStepT . foldr Yield Stop -- | Get the answers. @@ -269,7 +276,7 @@ -- | Run action for each value in the 'SourceT'. -- --- >>> foreach fail print (source "abc") +-- >>> foreach fail print $ source ("abc" :: String) -- 'a' -- 'b' -- 'c' @@ -342,16 +349,16 @@ -- -- >>> let parser = A.skipWhile A8.isSpace_w8 >> A.takeWhile1 A8.isDigit_w8 -- --- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1 2 3"]) +-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ [fromString "1 2 3"]) -- Right ["1","2","3"] -- --- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2", "3"]) +-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ map fromString ["1", "2", "3"]) -- Right ["123"] -- --- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["1", "2 3", "4"]) +-- >>> runExcept $ runSourceT $ transformWithAtto parser (source $ map fromString ["1", "2 3", "4"]) -- Right ["12","34"] -- --- >>> runExcept $ runSourceT $ transformWithAtto parser (source ["foobar"]) +-- >>> runExcept $ runSourceT $ transformWithAtto parser (source [fromString "foobar"]) -- Left "Failed reading: takeWhile1" -- transformWithAtto :: Monad m => A.Parser a -> SourceT m BS.ByteString -> SourceT m a diff --git a/test/Servant/API/ResponseHeadersSpec.hs b/test/Servant/API/ResponseHeadersSpec.hs --- a/test/Servant/API/ResponseHeadersSpec.hs +++ b/test/Servant/API/ResponseHeadersSpec.hs @@ -2,10 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} module Servant.API.ResponseHeadersSpec where +import Data.Proxy +import GHC.TypeLits import Test.Hspec +import Servant.API.ContentTypes import Servant.API.Header import Servant.API.ResponseHeaders +import Servant.API.UVerb spec :: Spec spec = describe "Servant.API.ResponseHeaders" $ do @@ -28,3 +32,10 @@ it "does not add a header" $ do let val = noHeader 5 :: Headers '[Header "test" Int] Int getHeaders val `shouldBe` [] + + describe "HasStatus Headers" $ do + + it "gets the status from the underlying value" $ do + natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] NoContent))) `shouldBe` 204 + natVal (Proxy :: Proxy (StatusOf (Headers '[Header "first" Int] (WithStatus 503 ())))) `shouldBe` 503 +