servant-server 0.18 → 0.18.1
raw patch · 6 files changed
+206/−30 lines, 6 filesdep +sop-coredep ~hspec-waidep ~http-api-datadep ~servantnew-uploader
Dependencies added: sop-core
Dependency ranges changed: hspec-wai, http-api-data, servant, wai-extra
Files
- CHANGELOG.md +12/−0
- servant-server.cabal +8/−11
- src/Servant/Server.hs +2/−0
- src/Servant/Server/Internal.hs +4/−4
- src/Servant/Server/UVerb.hs +96/−0
- test/Servant/ServerSpec.hs +84/−15
CHANGELOG.md view
@@ -1,6 +1,18 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.18.1+------++### Significant changes++- Union verbs++### Other changes++- Bump "tested-with" ghc versions+- Allow newer dependencies+ 0.18 ----
servant-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-server-version: 0.18+version: 0.18.1 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web@@ -23,13 +23,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple-tested-with:- GHC ==8.0.2- || ==8.2.2- || ==8.4.4- || ==8.6.5- || ==8.8.3- || ==8.10.1+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 extra-source-files: CHANGELOG.md@@ -57,6 +51,7 @@ Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles+ Servant.Server.UVerb -- deprecated exposed-modules:@@ -77,7 +72,7 @@ -- strict dependency as we re-export 'servant' things. build-depends: servant >= 0.18 && < 0.19.1- , http-api-data >= 0.4.1 && < 0.4.2+ , http-api-data >= 0.4.1 && < 0.4.3 -- 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.@@ -90,6 +85,7 @@ , network-uri >= 2.6.1.0 && < 2.8 , monad-control >= 1.0.2.3 && < 1.1 , network >= 2.8 && < 3.2+ , sop-core >= 0.4.0.0 && < 0.6 , string-conversions >= 0.4.0.1 && < 0.5 , resourcet >= 1.2.2 && < 1.3 , tagged >= 0.8.6 && < 0.9@@ -100,6 +96,7 @@ hs-source-dirs: src default-language: Haskell2010+ ghc-options: -Wall -Wno-redundant-constraints executable greet@@ -161,11 +158,11 @@ aeson >= 1.4.1.0 && < 1.6 , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.8- , hspec-wai >= 0.10.1 && < 0.11+ , hspec-wai >= 0.10.1 && < 0.12 , QuickCheck >= 2.12.6.1 && < 2.14 , should-not-typecheck >= 2.1.0 && < 2.2 , temporary >= 1.3 && < 1.4- , wai-extra >= 3.0.24.3 && < 3.1+ , wai-extra >= 3.0.24.3 && < 3.2 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && <2.8
src/Servant/Server.hs view
@@ -110,6 +110,7 @@ -- * Re-exports , Application , Tagged (..)+ , module Servant.Server.UVerb ) where @@ -122,6 +123,7 @@ import Network.Wai (Application) import Servant.Server.Internal+import Servant.Server.UVerb -- * Implementing Servers
src/Servant/Server/Internal.hs view
@@ -65,7 +65,7 @@ (SockAddr) import Network.Wai (Application, Request, httpVersion, isSecure, lazyRequestBody,- queryString, remoteHost, requestBody, requestHeaders,+ queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestMethod, responseLBS, responseStream, vault) import Prelude () import Prelude.Compat@@ -681,7 +681,7 @@ bodyCheck fromRS = withRequest $ \req -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk- let body = requestBody req+ let body = getRequestBodyChunk req let rs = S.fromAction B.null body let rs' = fromRS $ framingUnrender' rs return rs'@@ -750,12 +750,12 @@ emptyServer :: ServerT EmptyAPI m emptyServer = Tagged EmptyServer --- | The server for an `EmptyAPI` is `emptyAPIServer`.+-- | The server for an `EmptyAPI` is `emptyServer`. -- -- > type MyApi = "nothing" :> EmptyApi -- > -- > server :: Server MyApi--- > server = emptyAPIServer+-- > server = emptyServer instance HasServer EmptyAPI context where type ServerT EmptyAPI m = Tagged m EmptyServer
+ src/Servant/Server/UVerb.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Servant.Server.UVerb+ ( respond,+ IsServerResource,+ )+where++import Data.Proxy (Proxy (Proxy))+import Data.SOP (I (I))+import Data.SOP.Constraint (All, And)+import Data.String.Conversions (LBS, cs)+import Network.HTTP.Types (Status, hContentType)+import Network.Wai (responseLBS)+import Servant.API (ReflectMethod, reflectMethod)+import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf)+import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)+++-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,+-- and will construct a union value in an 'Applicative' (eg. 'Server').+respond ::+ forall (x :: *) (xs :: [*]) (f :: * -> *).+ (Applicative f, HasStatus x, IsMember x xs) =>+ x ->+ f (Union xs)+respond = pure . inject . I++-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.+type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus++instance+ ( ReflectMethod method,+ AllMime contentTypes,+ All (IsServerResource contentTypes) as,+ Unique (Statuses as) -- for consistency with servant-swagger (server would work fine+ -- wihtout; client is a bit of a corner case, because it dispatches+ -- the parser based on the status code. with this uniqueness+ -- constraint it won't have to run more than one parser in weird+ -- corner cases.+ ) =>+ HasServer (UVerb method contentTypes as) context+ where+ type ServerT (UVerb method contentTypes as) m = m (Union as)++ hoistServerWithContext _ _ nt s = nt s++ route ::+ forall env.+ Proxy (UVerb method contentTypes as) ->+ Context context ->+ Delayed env (Server (UVerb method contentTypes as)) ->+ Router env+ route _proxy _ctx action = leafRouter route'+ where+ method = reflectMethod (Proxy @method)+ route' env request cont = do+ let action' :: Delayed env (Handler (Union as))+ action' =+ action+ `addMethodCheck` methodCheck method request+ `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)+ mkProxy :: a -> Proxy a+ mkProxy _ = Proxy++ runAction action' env request cont $ \(output :: Union as) -> do+ let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))+ encodeResource res =+ ( statusOf $ mkProxy res,+ handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res+ )+ pickResource :: Union as -> (Status, Maybe (LBS, LBS))+ pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource++ case pickResource output of+ (_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does+ (status, Just (contentT, body)) ->+ let bdy = if allowedMethodHead method request then "" else body+ in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy
test/Servant/ServerSpec.hs view
@@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where@@ -49,14 +48,16 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,- Delete, EmptyAPI, Get, Header, Headers, HttpVersion,- IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,- NoFraming, OctetStream, Patch, PlainText, Post, Put,- QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,- SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader)+ Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,+ HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),+ NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,+ Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,+ ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,+ UVerb, Verb, addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..),- emptyServer, err401, err403, err404, serve, serveWithContext)+ emptyServer, err401, err403, err404, respond, serve,+ serveWithContext) import Servant.Test.ComprehensiveAPI import qualified Servant.Types.SourceT as S import Test.Hspec@@ -87,6 +88,7 @@ spec :: Spec spec = do verbSpec+ uverbSpec captureSpec captureAllSpec queryParamSpec@@ -253,8 +255,8 @@ with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw))- (\ "captured" -> Tagged $ \request_ respond ->- respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do+ (\ "captured" -> Tagged $ \request_ sendResponse ->+ sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) @@ -305,8 +307,8 @@ with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw))- (\ _captured -> Tagged $ \request_ respond ->- respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do+ (\ _captured -> Tagged $ \request_ sendResponse ->+ sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "consumes everything from pathInfo" $ do get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) @@ -544,8 +546,8 @@ rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Tagged m Application-rawApplication f = Tagged $ \request_ respond ->- respond $ responseLBS ok200 []+rawApplication f = Tagged $ \request_ sendResponse ->+ sendResponse $ responseLBS ok200 [] (cs $ show $ f request_) rawSpec :: Spec@@ -706,7 +708,7 @@ basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|>- (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")+ (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext =@@ -751,7 +753,7 @@ genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety)- :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")+ :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -780,6 +782,73 @@ it "plays nice with subsequent Raw endpoints" $ do get "/foo" `shouldRespondWith` 418++-- }}}+------------------------------------------------------------------------------+-- * UVerb {{{+------------------------------------------------------------------------------++newtype PersonResponse = PersonResponse Person+ deriving Generic+instance ToJSON PersonResponse+instance HasStatus PersonResponse where+ type StatusOf PersonResponse = 200++newtype RedirectResponse = RedirectResponse String+ deriving Generic+instance ToJSON RedirectResponse+instance HasStatus RedirectResponse where+ type StatusOf RedirectResponse = 301++newtype AnimalResponse = AnimalResponse Animal+ deriving Generic+instance ToJSON AnimalResponse+instance HasStatus AnimalResponse where+ type StatusOf AnimalResponse = 203+++type UVerbApi+ = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]+ :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]++uverbSpec :: Spec+uverbSpec = describe "Servant.API.UVerb " $ do+ let+ joe = Person "joe" 42+ mouse = Animal "Mouse" 7++ personHandler+ :: Bool+ -> Handler (Union '[PersonResponse+ ,RedirectResponse])+ personHandler True = respond $ RedirectResponse "over there!"+ personHandler False = respond $ PersonResponse joe++ animalHandler = respond $ AnimalResponse mouse++ server :: Server UVerbApi+ server = personHandler :<|> animalHandler++ with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do+ context "A route returning either 301/String or 200/Person" $ do+ context "when requesting the person" $ do+ let theRequest = THW.get "/person/false"+ it "returns status 200" $+ theRequest `shouldRespondWith` 200+ it "returns a person" $ do+ response <- theRequest+ liftIO $ decode' (simpleBody response) `shouldBe` Just joe+ context "requesting the redirect" $+ it "returns a message and status 301" $+ THW.get "/person/true"+ `shouldRespondWith` "\"over there!\"" {matchStatus = 301}+ context "a route with a single response type" $ do+ let theRequest = THW.get "/animal"+ it "should return the defined status code" $+ theRequest `shouldRespondWith` 203+ it "should return the expected response" $ do+ response <- theRequest+ liftIO $ decode' (simpleBody response) `shouldBe` Just mouse -- }}} ------------------------------------------------------------------------------