servant 0.19.1 → 0.20
raw patch · 15 files changed
+156/−49 lines, 15 filesdep ~basedep ~bifunctorsdep ~hspec
Dependency ranges changed: base, bifunctors, hspec, http-api-data, mtl, singleton-bool, transformers
Files
- CHANGELOG.md +20/−0
- servant.cabal +12/−11
- src/Servant/API.hs +10/−6
- src/Servant/API/ContentTypes.hs +4/−3
- src/Servant/API/Raw.hs +3/−0
- src/Servant/API/ResponseHeaders.hs +35/−14
- src/Servant/API/Stream.hs +2/−2
- src/Servant/API/TypeErrors.hs +19/−0
- src/Servant/API/UVerb.hs +3/−0
- src/Servant/API/UVerb/Union.hs +6/−4
- src/Servant/API/WithResource.hs +3/−0
- src/Servant/Links.hs +12/−1
- src/Servant/Test/ComprehensiveAPI.hs +1/−0
- src/Servant/Types/SourceT.hs +15/−8
- test/Servant/API/ResponseHeadersSpec.hs +11/−0
CHANGELOG.md view
@@ -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 ------
servant.cabal view
@@ -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
src/Servant/API.hs view
@@ -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
src/Servant/API/ContentTypes.hs view
@@ -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
src/Servant/API/Raw.hs view
@@ -15,3 +15,6 @@ -- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles> -- 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
src/Servant/API/ResponseHeaders.hs view
@@ -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- -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>) 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
src/Servant/API/Stream.hs view
@@ -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 =
src/Servant/API/TypeErrors.hs view
@@ -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+ )
src/Servant/API/UVerb.hs view
@@ -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. --
src/Servant/API/UVerb/Union.hs view
@@ -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))
+ src/Servant/API/WithResource.hs view
@@ -0,0 +1,3 @@+module Servant.API.WithResource (WithResource) where++data WithResource res
src/Servant/Links.hs view
@@ -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)
src/Servant/Test/ComprehensiveAPI.hs view
@@ -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
src/Servant/Types/SourceT.hs view
@@ -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
test/Servant/API/ResponseHeadersSpec.hs view
@@ -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+