9ccb5afa9f
This commit introduces a new type-level combinator, `WithRoutingHeader`.
It modifies the behaviour of the following sub-API, such that all endpoint
of said API return an additional routing header in their response.
A routing header is a header that specifies which endpoint the
incoming request was routed to.
Endpoint are designated by their path, in which `Capture'` and
`CaptureAll` combinators are replaced by a capture hint.
This header can be used by downstream middlewares to gather
information about individual endpoints, since in most cases
a routing header uniquely identifies a single endpoint.
Example:
```haskell
type MyApi =
WithRoutingHeader :> "by-id" :> Capture "id" Int :> Get '[JSON] Foo
-- GET /by-id/1234 will return a response with the following header:
-- ("Servant-Routed-Path", "/by-id/<id::Int>")
```
To achieve this, two refactorings were necessary:
* Introduce a type `RouterEnv env` to encapsulate the `env` type
(as in `Router env a`), which contains a tuple-encoded list of url
pieces parsed from the incoming request.
This type makes it possible to pass more information throughout the
routing process, and the computation of the `Delayed env c` associated
with each request.
* Introduce a new kind of router, which only modifies the RouterEnv, and
doesn't affect the routing process otherwise.
`EnvRouter (RouterEnv env -> RouterEnv env) (Router' env a)`
This new router is used when encountering the `WithRoutingHeader`
combinator in an API, to notify the endpoints of the sub-API that they
must produce a routing header (this behaviour is disabled by default).
151 lines
5.2 KiB
Haskell
151 lines
5.2 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
module Servant.Server.Internal.RoutingApplicationSpec (spec) where
|
|
|
|
import Prelude ()
|
|
import Prelude.Compat
|
|
|
|
import Control.Exception hiding
|
|
(Handler)
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Trans.Resource
|
|
(register)
|
|
import Data.IORef
|
|
import Data.Proxy
|
|
import GHC.TypeLits
|
|
(KnownSymbol, Symbol, symbolVal)
|
|
import Network.Wai
|
|
(defaultRequest)
|
|
import Servant
|
|
import Servant.Server.Internal
|
|
import Test.Hspec
|
|
import Test.Hspec.Wai
|
|
(request, shouldRespondWith, with)
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import System.IO.Unsafe
|
|
(unsafePerformIO)
|
|
|
|
data TestResource x
|
|
= TestResourceNone
|
|
| TestResource x
|
|
| TestResourceFreed
|
|
| TestResourceError
|
|
deriving (Eq, Show)
|
|
|
|
-- Let's not write to the filesystem
|
|
delayedTestRef :: IORef (TestResource String)
|
|
delayedTestRef = unsafePerformIO $ newIORef TestResourceNone
|
|
|
|
fromTestResource :: a -> (b -> a) -> TestResource b -> a
|
|
fromTestResource _ f (TestResource x) = f x
|
|
fromTestResource x _ _ = x
|
|
|
|
initTestResource :: IO ()
|
|
initTestResource = writeIORef delayedTestRef TestResourceNone
|
|
|
|
writeTestResource :: String -> IO ()
|
|
writeTestResource x = modifyIORef delayedTestRef $ \r -> case r of
|
|
TestResourceNone -> TestResource x
|
|
_ -> TestResourceError
|
|
|
|
freeTestResource :: IO ()
|
|
freeTestResource = modifyIORef delayedTestRef $ \r -> case r of
|
|
TestResource _ -> TestResourceFreed
|
|
_ -> TestResourceError
|
|
|
|
delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
|
|
delayed body srv = Delayed
|
|
{ capturesD = \() -> return ()
|
|
, methodD = return ()
|
|
, authD = return ()
|
|
, acceptD = return ()
|
|
, contentD = return ()
|
|
, paramsD = return ()
|
|
, headersD = return ()
|
|
, bodyD = \() -> do
|
|
liftIO (writeTestResource "hia" >> putStrLn "garbage created")
|
|
_ <- register (freeTestResource >> putStrLn "garbage collected")
|
|
body
|
|
, serverD = \() () () () _body _req -> srv
|
|
}
|
|
|
|
simpleRun :: Delayed () (Handler ())
|
|
-> IO ()
|
|
simpleRun d = fmap (either ignoreE id) . try $
|
|
runAction d (emptyEnv ()) defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
|
|
|
|
where ignoreE :: SomeException -> ()
|
|
ignoreE = const ()
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Combinator example
|
|
-------------------------------------------------------------------------------
|
|
|
|
-- | This data types writes 'sym' to 'delayedTestRef'.
|
|
data Res (sym :: Symbol)
|
|
|
|
instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
|
|
type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m
|
|
|
|
hoistServerWithContext _ nc nt s = hoistServerWithContext (Proxy :: Proxy api) nc nt . s
|
|
|
|
route Proxy ctx server = route (Proxy :: Proxy api) ctx $
|
|
addBodyCheck server (return ()) check
|
|
where
|
|
sym = symbolVal (Proxy :: Proxy sym)
|
|
check () = do
|
|
liftIO $ writeTestResource sym
|
|
_ <- register freeTestResource
|
|
return delayedTestRef
|
|
|
|
type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
|
|
|
|
resApi :: Proxy ResApi
|
|
resApi = Proxy
|
|
|
|
resServer :: Server ResApi
|
|
resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Spec
|
|
-------------------------------------------------------------------------------
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
describe "Delayed" $ do
|
|
it "actually runs clean up actions" $ do
|
|
liftIO initTestResource
|
|
_ <- simpleRun $ delayed (return ()) (Route $ return ())
|
|
res <- readIORef delayedTestRef
|
|
res `shouldBe` TestResourceFreed
|
|
it "even with exceptions in serverD" $ do
|
|
liftIO initTestResource
|
|
_ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
|
|
res <- readIORef delayedTestRef
|
|
res `shouldBe` TestResourceFreed
|
|
it "even with routing failure in bodyD" $ do
|
|
liftIO initTestResource
|
|
_ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
|
|
res <- readIORef delayedTestRef
|
|
res `shouldBe` TestResourceFreed
|
|
it "even with exceptions in bodyD" $ do
|
|
liftIO initTestResource
|
|
_ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
|
|
res <- readIORef delayedTestRef
|
|
res `shouldBe` TestResourceFreed
|
|
describe "ResApi" $
|
|
with (return $ serve resApi resServer) $ do
|
|
it "writes and cleanups resources" $ do
|
|
liftIO initTestResource
|
|
request "GET" "foobar" [] "" `shouldRespondWith` "foobar"
|
|
liftIO $ do
|
|
res <- readIORef delayedTestRef
|
|
res `shouldBe` TestResourceFreed
|