0cf4a54 · servant · git.iko.soy

git.iko.soy/servant

Merge pull request #254 from zerobuzz/fmap-router

fmapRouter.

commit0cf4a5407e363aa69a02734a6dba1d8844607e9d authorJulian Arni <jkarni@gmail.com> dateTue 13 Oct 2015, 09:37 (11 years ago) parent80396c8 8f01efd

3 files changed+52−16

compare with master

unifiedsplit

servant-server/src/Servant/Server.hs+1−1 servant-server/src/Servant/Server/Internal/Router.hs+12−4 servant-server/test/Servant/ServerSpec.hs+39−11

servant-server/src/Servant/Server.hs+1−1

@@ -33,7 +33,7 @@ module Servant.Server

3333 , embedNat

3434 , squashNat

3535 , generalizeNat

36−

36+ , tweakResponse

3737

3838 -- * Default error type

3939 , ServantErr(..)

servant-server/src/Servant/Server/Internal/Router.hs+12−4

@@ -1,25 +1,34 @@

1+{-# LANGUAGE DeriveFunctor #-}

13module Servant.Server.Internal.Router where

35import Data.Map (Map)

46import qualified Data.Map as M

57import Data.Monoid ((<>))

68import Data.Text (Text)

7−import Network.Wai (Request, pathInfo)

9+import Network.Wai (Request, Response, pathInfo)

810import Servant.Server.Internal.PathInfo

911import Servant.Server.Internal.RoutingApplication

1012

13+type Router = Router' RoutingApplication

14+

1115-- | Internal representation of a router.

12−data Router =

16+data Router' a =

1317 WithRequest (Request -> Router)

1418 -- ^ current request is passed to the router

1519 | StaticRouter (Map Text Router)

1620 -- ^ first path component used for lookup and removed afterwards

1721 | DynamicRouter (Text -> Router)

1822 -- ^ first path component used for lookup and removed afterwards

19− | LeafRouter RoutingApplication

23+ | LeafRouter a

2024 -- ^ to be used for routes that match an empty path

2125 | Choice Router Router

2226 -- ^ left-biased choice between two routers

27+ deriving Functor

28+

29+-- | Apply a transformation to the response of a `Router`.

30+tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router

31+tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))

2332

2433-- | Smart constructor for the choice between routers.

2534-- We currently optimize the following cases:

@@ -69,4 +78,3 @@ runRouter (Choice r1 r2) request respond =

6978 then runRouter r2 request $ \ mResponse2 ->

7079 respond (mResponse1 <> mResponse2)

7180 else respond mResponse1

72−

servant-server/test/Servant/ServerSpec.hs+39−11

@@ -1,14 +1,17 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE TypeOperators #-}

6−{-# LANGUAGE TypeSynonymInstances #-}

7−{-# LANGUAGE FlexibleInstances #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE TypeSynonymInstances #-}

8+{-# LANGUAGE FlexibleInstances #-}

910module Servant.ServerSpec where

1011

11−

12+#if !MIN_VERSION_base(4,8,0)

13+import Control.Applicative ((<$>))

14+#endif

1215import Control.Monad (forM_, when)

1316import Control.Monad.Trans.Except (ExceptT, throwE)

1417import Data.Aeson (FromJSON, ToJSON, decode', encode)

@@ -23,10 +26,12 @@ import GHC.Generics (Generic)

2326import Network.HTTP.Types (hAccept, hContentType,

2427 methodDelete, methodGet, methodHead,

2528 methodPatch, methodPost, methodPut,

26− ok200, parseQuery, status409)

29+ ok200, parseQuery, status409,

30+ Status(..))

2731import Network.Wai (Application, Request, pathInfo,

2832 queryString, rawQueryString,

29− responseLBS)

33+ responseLBS, responseBuilder)

34+import Network.Wai.Internal (Response(ResponseBuilder))

3035import Network.Wai.Test (defaultRequest, request,

3136 runSession, simpleBody)

3237import Test.Hspec (Spec, describe, it, shouldBe)

@@ -41,8 +46,12 @@ import Servant.API ((:<|>) (..), (:>),

4146 Post, Put, RemoteHost, QueryFlag, QueryParam,

4247 QueryParams, Raw, ReqBody)

4348import Servant.Server (Server, serve, ServantErr(..), err404)

49+import Servant.Server.Internal.Router

50+ (tweakResponse, runRouter,

51+ Router, Router'(LeafRouter))

4452import Servant.Server.Internal.RoutingApplication

45− (RouteMismatch (..))

53+ (RouteResult(..), RouteMismatch(..),

54+ toApplication)

4655

4756

4857-- * test data types

@@ -92,6 +101,7 @@ spec = do

92101 unionSpec

93102 prioErrorsSpec

94103 errorsSpec

104+ routerSpec

95105 responseHeadersSpec

96106 miscReqCombinatorsSpec

97107

@@ -697,6 +707,24 @@ errorsSpec = do

697707 nf <> ib `shouldBe` ib

698708 nf <> wm `shouldBe` wm

699709

710+routerSpec :: Spec

711+routerSpec = do

712+ describe "Servant.Server.Internal.Router" $ do

713+ let app' :: Application

714+ app' = toApplication $ runRouter router'

715+

716+ router', router :: Router

717+ router' = tweakResponse (twk <$>) router

718+ router = LeafRouter $ \_ cont -> cont (RR . Right $ responseBuilder (Status 201 "") [] "")

719+

720+ twk :: Response -> Response

721+ twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b

722+ twk b = b

723+

724+ describe "tweakResponse" . with (return app') $ do

725+ it "calls f on route result" $ do

726+ get "" `shouldRespondWith` 202

727+

700728type MiscCombinatorsAPI

701729 = "version" :> HttpVersion :> Get '[JSON] String

702730 :<|> "secure" :> IsSecure :> Get '[JSON] String