servant/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs

143 lines
4.8 KiB
Haskell
Raw Normal View History

2017-01-18 11:17:38 +01:00
{-# 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)
2017-01-18 10:37:18 +01:00
import Control.Monad.Trans.Resource (register)
import Control.Monad.IO.Class
import Data.IORef
2017-01-18 11:17:38 +01:00
import Data.Proxy
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Servant
import Servant.Server.Internal.RoutingApplication
2017-01-16 13:17:20 +01:00
import Network.Wai (defaultRequest)
import Test.Hspec
2017-01-18 11:17:38 +01:00
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
2017-01-16 13:17:20 +01:00
{ capturesD = \() -> return ()
2017-01-18 10:37:18 +01:00
, methodD = return ()
, authD = return ()
2017-01-16 13:17:20 +01:00
, acceptD = return ()
, contentD = return ()
, paramsD = return ()
, headersD = return ()
2017-01-16 13:17:20 +01:00
, 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 $
2017-01-16 13:17:20 +01:00
runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
where ignoreE :: SomeException -> ()
ignoreE = const ()
2017-01-18 11:17:38 +01:00
-------------------------------------------------------------------------------
-- 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
2017-01-18 11:17:38 +01:00
route Proxy ctx server = route (Proxy :: Proxy api) ctx $
2017-01-16 13:17:20 +01:00
addBodyCheck server (return ()) check
2017-01-18 11:17:38 +01:00
where
sym = symbolVal (Proxy :: Proxy sym)
2017-01-16 13:17:20 +01:00
check () = do
liftIO $ writeTestResource sym
_ <- register freeTestResource
2017-01-18 11:17:38 +01:00
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
2017-01-18 11:17:38 +01:00
-------------------------------------------------------------------------------
-- 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
2017-01-18 11:17:38 +01:00
describe "ResApi" $
with (return $ serve resApi resServer) $ do
it "writes and cleanups resources" $ do
liftIO initTestResource
2017-01-18 11:17:38 +01:00
request "GET" "foobar" [] "" `shouldRespondWith` "foobar"
liftIO $ do
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed