added Servant.API.Raw (only with HasServer)

servant.cabal

@@ -23,6 +23,7 @@ library
     Servant.API.Get
     Servant.API.GetParam
     Servant.API.Post
+    Servant.API.Raw
     Servant.API.RQBody
     Servant.API.Sub
     Servant.API.Union

src/Servant/API/Capture.hs

@@ -26,14 +26,14 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
   type Server (Capture capture a :> sublayout) =
      a -> Server sublayout
 
-  route Proxy subserver request = case pathInfo request of
+  route Proxy subserver globalPathInfo request respond = case pathInfo request of
     (first : rest)
       -> case captured captureProxy first of
-           Nothing  -> return Nothing
+           Nothing  -> respond Nothing
-           Just v   -> route (Proxy :: Proxy sublayout) (subserver v) request{
+           Just v   -> route (Proxy :: Proxy sublayout) (subserver v) globalPathInfo request{
                          pathInfo = rest
-                       }
+                       } respond
-    _ -> return Nothing
+    _ -> respond Nothing
 
     where captureProxy = Proxy :: Proxy (Capture capture a)
 

src/Servant/API/Get.hs

@@ -22,15 +22,15 @@ data Get a
 
 instance ToJSON result => HasServer (Get result) where
   type Server (Get result) = EitherT (Int, String) IO result
-  route Proxy action request
+  route Proxy action _globalPathInfo request respond
     | null (pathInfo request) && requestMethod request == methodGet = do
         e <- runEitherT action
-        return $ Just $ case e of
+        respond $ Just $ case e of
           Right output ->
             responseLBS ok200 [("Content-Type", "application/json")] (encode output)
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
-    | otherwise = return Nothing
+    | otherwise = respond Nothing
 
 instance FromJSON result => HasClient (Get result) where
   type Client (Get result) = URI -> EitherT String IO result

src/Servant/API/GetParam.hs

@@ -25,7 +25,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
   type Server (GetParam sym a :> sublayout) =
     Maybe a -> Server sublayout
 
-  route Proxy subserver request = do
+  route Proxy subserver globalPathInfo request respond = do
     let querytext = parseQueryText $ rawQueryString request
         param =
           case lookup paramName querytext of
@@ -34,7 +34,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
             Just (Just v) -> fromText v -- if present, we try to convert to
                                         -- the right type
 
-    route (Proxy :: Proxy sublayout) (subserver param) request
+    route (Proxy :: Proxy sublayout) (subserver param) globalPathInfo request respond
 
     where paramName = cs $ symbolVal (Proxy :: Proxy sym)
 

src/Servant/API/Post.hs

@@ -22,15 +22,15 @@ data Post a
 instance ToJSON a => HasServer (Post a) where
   type Server (Post a) = EitherT (Int, String) IO a
 
-  route Proxy action request
+  route Proxy action _globalPathInfo request respond
     | null (pathInfo request) && requestMethod request == methodPost = do
         e <- runEitherT action
-        return $ Just $ case e of
+        respond $ Just $ case e of
           Right out ->
             responseLBS status201 [("Content-Type", "application/json")] (encode out)
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
-    | otherwise = return Nothing
+    | otherwise = respond Nothing
 
 instance FromJSON a => HasClient (Post a) where
   type Client (Post a) = URI -> EitherT String IO a

src/Servant/API/RQBody.hs

@@ -22,11 +22,11 @@ instance (FromJSON a, HasServer sublayout)
   type Server (RQBody a :> sublayout) =
     a -> Server sublayout
 
-  route Proxy subserver request = do
+  route Proxy subserver globalPathInfo request respond = do
     mrqbody <- decode' <$> lazyRequestBody request
     case mrqbody of
-      Nothing -> return Nothing
+      Nothing -> respond Nothing
-      Just v  -> route (Proxy :: Proxy sublayout) (subserver v) request
+      Just v  -> route (Proxy :: Proxy sublayout) (subserver v) globalPathInfo request respond
 
 instance (ToJSON a, HasClient sublayout)
       => HasClient (RQBody a :> sublayout) where

src/Servant/API/Raw.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Servant.API.Raw where
+
+import Data.Proxy
+import Network.Wai
+import Servant.Server
+
+-- | Endpoint for plugging in your own Wai 'Application's.
+-- The given Application will get the original request received by the server
+-- (i.e. with unmodified 'pathInfo', etc.)
+data Raw
+
+instance HasServer Raw where
+  type Server Raw = Application
+  route Proxy rawApplication globalPathInfo request respond =
+    rawApplication request{pathInfo = globalPathInfo} (respond . Just)

src/Servant/API/Sub.hs

@@ -18,13 +18,13 @@ infixr 9 :>
 
 instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
   type Server (path :> sublayout) = Server sublayout
-  route Proxy subserver request = case pathInfo request of
+  route Proxy subserver globalPathInfo request respond = case pathInfo request of
     (first : rest)
       | first == cs (symbolVal proxyPath)
-      -> route (Proxy :: Proxy sublayout) subserver request{
+      -> route (Proxy :: Proxy sublayout) subserver globalPathInfo request{
            pathInfo = rest
-         }
+         } respond
-    _ -> return Nothing
+    _ -> respond Nothing
 
     where proxyPath = Proxy :: Proxy path
 

src/Servant/API/Union.hs

@@ -13,14 +13,14 @@ infixr 8 :<|>
 
 instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
   type Server (a :<|> b) = Server a :<|> Server b
-  route Proxy (a :<|> b) request = do
+  route Proxy (a :<|> b) globalPathInfo request respond = do
-    m <- route (Proxy :: Proxy a) a request
+    route (Proxy :: Proxy a) a globalPathInfo request $ \ mResponse ->
-    case m of
+      case mResponse of
-      Nothing -> route (Proxy :: Proxy b) b request
+        Nothing -> route (Proxy :: Proxy b) b globalPathInfo request respond
-      Just response -> return $ Just response
+        Just response -> respond $ Just response
 
 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
   type Client (a :<|> b) = Client a :<|> Client b
   clientWithRoute Proxy req =
     clientWithRoute (Proxy :: Proxy a) req :<|>
-    clientWithRoute (Proxy :: Proxy b) req
+    clientWithRoute (Proxy :: Proxy b) req

src/Servant/Server.hs

@@ -3,6 +3,7 @@
 module Servant.Server where
 
 import Data.Proxy
+import Data.Text
 import Network.HTTP.Types
 import Network.Wai
 
@@ -13,14 +14,19 @@ serve :: HasServer layout => Proxy layout -> Server layout -> Application
 serve p server = toApplication (route p server)
 
 toApplication :: RoutingApplication -> Application
-toApplication ra = \ request respond -> do
+toApplication ra request respond = do
-  m <- ra request
+  ra (pathInfo request) request routingRespond
-  case m of
+ where
-    Nothing -> respond $ responseLBS notFound404 [] "not found"
+  routingRespond :: Maybe Response -> IO ResponseReceived
-    Just response -> respond response
+  routingRespond Nothing =
+    respond $ responseLBS notFound404 [] "not found"
+  routingRespond (Just response) =
+    respond response
 
 type RoutingApplication =
-  Request -> IO (Maybe Response)
+     [Text] -- ^ the unmodified 'pathInfo'
+  -> Request -- ^ the request, the field 'pathInfo' may be modified by url routing
+  -> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived
 
 class HasServer layout where
   type Server layout :: *

test/Servant/ServerSpec.hs

@@ -10,6 +10,7 @@ module Servant.ServerSpec where
 
 import Data.Aeson
 import Data.Proxy
+import Data.String.Conversions
 import GHC.Generics
 import Network.HTTP.Types
 import Network.Wai
@@ -20,6 +21,7 @@ import Test.Hspec.Wai
 import Servant.API.Get
 import Servant.API.GetParam
 import Servant.API.Post
+import Servant.API.Raw
 import Servant.API.RQBody
 import Servant.API.Sub
 import Servant.API.Union
@@ -60,6 +62,7 @@ spec = do
   getSpec
   getParamSpec
   postSpec
+  rawSpec
   unionSpec
 
 
@@ -67,7 +70,8 @@ type GetApi = Get Person
 getApi :: Proxy GetApi
 getApi = Proxy
 
-getSpec :: Spec = do
+getSpec :: Spec
+getSpec = do
   describe "Servant.API.Get" $ do
     with (return (serve getApi (return alice))) $ do
       it "allows to GET a Person" $ do
@@ -118,6 +122,32 @@ postSpec = do
          }
 
 
+type RawApi = "foo" :> Raw
+rawApi :: Proxy RawApi
+rawApi = Proxy
+rawApplication :: Show a => (Request -> a) -> Application
+rawApplication f request respond = respond $ responseLBS ok200 [] (cs $ show $ f request)
+
+rawSpec :: Spec
+rawSpec = do
+  describe "Servant.API.Raw" $ do
+    it "runs applications" $ do
+      (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
+        response <- Network.Wai.Test.request defaultRequest{
+          pathInfo = ["foo"]
+         }
+        liftIO $ do
+          simpleBody response `shouldBe` "42"
+
+    it "gets the pathInfo unmodified" $ do
+      (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
+        response <- Network.Wai.Test.request defaultRequest{
+          pathInfo = ["foo"]
+         }
+        liftIO $ do
+          simpleBody response `shouldBe` cs (show ["foo" :: String])
+
+
 type UnionApi =
        "foo" :> Get Person
   :<|> "bar" :> Get Animal