From 96f10add650500e22b12859a913f027996a334d7 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 12 Oct 2015 17:06:43 +0200 Subject: [PATCH 1/5] fmapRouter. --- servant-server/src/Servant/Server/Internal/Router.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index f188955e..3c8eb722 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -4,7 +4,7 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Monoid ((<>)) import Data.Text (Text) -import Network.Wai (Request, pathInfo) +import Network.Wai (Request, Response, pathInfo) import Servant.Server.Internal.PathInfo import Servant.Server.Internal.RoutingApplication @@ -21,6 +21,13 @@ data Router = | Choice Router Router -- ^ left-biased choice between two routers +fmapRouter :: (RouteResult Response -> RouteResult Response) -> Router -> Router +fmapRouter f (LeafRouter a) = LeafRouter $ \req cont -> a req (cont . f) +fmapRouter f (StaticRouter m) = StaticRouter (fmapRouter f <$> m) +fmapRouter f (DynamicRouter d) = DynamicRouter (fmapRouter f <$> d) +fmapRouter f (Choice r1 r2) = Choice (fmapRouter f r1) (fmapRouter f r2) +fmapRouter f (WithRequest g) = WithRequest (fmapRouter f . g) + -- | Smart constructor for the choice between routers. -- We currently optimize the following cases: -- @@ -69,4 +76,3 @@ runRouter (Choice r1 r2) request respond = then runRouter r2 request $ \ mResponse2 -> respond (mResponse1 <> mResponse2) else respond mResponse1 - From d106ed9c9f36d6c815d492a5ddad5b3c4fe41c65 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 12 Oct 2015 18:51:43 +0200 Subject: [PATCH 2/5] Use Functor class for functor business. --- .../src/Servant/Server/Internal/Router.hs | 20 +++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 3c8eb722..653af681 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveFunctor #-} + module Servant.Server.Internal.Router where import Data.Map (Map) @@ -8,25 +10,27 @@ import Network.Wai (Request, Response, import Servant.Server.Internal.PathInfo import Servant.Server.Internal.RoutingApplication +type Router = Router' RoutingApplication + -- | Internal representation of a router. -data Router = +data Router' a = WithRequest (Request -> Router) -- ^ current request is passed to the router | StaticRouter (Map Text Router) -- ^ first path component used for lookup and removed afterwards | DynamicRouter (Text -> Router) -- ^ first path component used for lookup and removed afterwards - | LeafRouter RoutingApplication + | LeafRouter a -- ^ to be used for routes that match an empty path | Choice Router Router -- ^ left-biased choice between two routers + deriving Functor -fmapRouter :: (RouteResult Response -> RouteResult Response) -> Router -> Router -fmapRouter f (LeafRouter a) = LeafRouter $ \req cont -> a req (cont . f) -fmapRouter f (StaticRouter m) = StaticRouter (fmapRouter f <$> m) -fmapRouter f (DynamicRouter d) = DynamicRouter (fmapRouter f <$> d) -fmapRouter f (Choice r1 r2) = Choice (fmapRouter f r1) (fmapRouter f r2) -fmapRouter f (WithRequest g) = WithRequest (fmapRouter f . g) +-- | Apply a function to the result of a router in functor style. The result contains the failure +-- cases so one use case is to turn failures into middleware response values with appropriate status +-- codes, message bodies, etc. +tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router +tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) -- | Smart constructor for the choice between routers. -- We currently optimize the following cases: From f953d052121eeed357cbb21b5b28b9938bc2a14e Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 12 Oct 2015 19:14:42 +0200 Subject: [PATCH 3/5] Whitespace. --- servant-server/test/Servant/ServerSpec.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 45519e42..f1760633 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Servant.ServerSpec where From dd1d30843b55be449a04e83717f87c6bdfce325f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 12 Oct 2015 19:23:13 +0200 Subject: [PATCH 4/5] Test case for tweakResponse. --- servant-server/test/Servant/ServerSpec.hs | 36 ++++++++++++++++++++--- 1 file changed, 32 insertions(+), 4 deletions(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index f1760633..9c7e85c3 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,7 +9,9 @@ module Servant.ServerSpec where - +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif import Control.Monad (forM_, when) import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) @@ -23,10 +26,12 @@ import GHC.Generics (Generic) import Network.HTTP.Types (hAccept, hContentType, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, - ok200, parseQuery, status409) + ok200, parseQuery, status409, + Status(..)) import Network.Wai (Application, Request, pathInfo, queryString, rawQueryString, - responseLBS) + responseLBS, responseBuilder) +import Network.Wai.Internal (Response(ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody) import Test.Hspec (Spec, describe, it, shouldBe) @@ -41,8 +46,12 @@ import Servant.API ((:<|>) (..), (:>), Post, Put, RemoteHost, QueryFlag, QueryParam, QueryParams, Raw, ReqBody) import Servant.Server (Server, serve, ServantErr(..), err404) +import Servant.Server.Internal.Router + (tweakResponse, runRouter, + Router, Router'(LeafRouter)) import Servant.Server.Internal.RoutingApplication - (RouteMismatch (..)) + (RouteResult(..), RouteMismatch(..), + toApplication) -- * test data types @@ -92,6 +101,7 @@ spec = do unionSpec prioErrorsSpec errorsSpec + routerSpec responseHeadersSpec miscReqCombinatorsSpec @@ -697,6 +707,24 @@ errorsSpec = do nf <> ib `shouldBe` ib nf <> wm `shouldBe` wm +routerSpec :: Spec +routerSpec = do + describe "Servant.Server.Internal.Router" $ do + let app' :: Application + app' = toApplication $ runRouter router' + + router', router :: Router + router' = tweakResponse (twk <$>) router + router = LeafRouter $ \_ cont -> cont (RR . Right $ responseBuilder (Status 201 "") [] "") + + twk :: Response -> Response + twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b + twk b = b + + describe "tweakResponse" . with (return app') $ do + it "calls f on route result" $ do + get "" `shouldRespondWith` 202 + type MiscCombinatorsAPI = "version" :> HttpVersion :> Get '[JSON] String :<|> "secure" :> IsSecure :> Get '[JSON] String From 8f01efd599892692bc03b9cac99fbfe78200e16a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 12 Oct 2015 20:52:15 +0200 Subject: [PATCH 5/5] Export tweakResponse from non-internal module; better haddock comment. --- servant-server/src/Servant/Server.hs | 2 +- servant-server/src/Servant/Server/Internal/Router.hs | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 58c34ea3..2a886683 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -33,7 +33,7 @@ module Servant.Server , embedNat , squashNat , generalizeNat - + , tweakResponse -- * Default error type , ServantErr(..) diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 653af681..89f7c144 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -26,9 +26,7 @@ data Router' a = -- ^ left-biased choice between two routers deriving Functor --- | Apply a function to the result of a router in functor style. The result contains the failure --- cases so one use case is to turn failures into middleware response values with appropriate status --- codes, message bodies, etc. +-- | Apply a transformation to the response of a `Router`. tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))