110 lines
3.9 KiB
Haskell
110 lines
3.9 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.Trans.Resource (register)
|
|
import Control.Monad.IO.Class
|
|
import Data.IORef
|
|
import Data.Maybe (isJust)
|
|
import Data.Proxy
|
|
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
|
|
import Servant
|
|
import Servant.Server.Internal.RoutingApplication
|
|
import Test.Hspec
|
|
import Test.Hspec.Wai (request, shouldRespondWith, with)
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import System.IO.Unsafe (unsafePerformIO)
|
|
|
|
-- Let's not write to the filesystem
|
|
delayedTestRef :: IORef (Maybe String)
|
|
delayedTestRef = unsafePerformIO $ newIORef Nothing
|
|
|
|
delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
|
|
delayed body srv = Delayed
|
|
{ capturesD = \_ -> return ()
|
|
, methodD = return ()
|
|
, authD = return ()
|
|
, bodyD = do
|
|
liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")
|
|
_ <- register (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")
|
|
body
|
|
, serverD = \() () _body _req -> srv
|
|
}
|
|
|
|
simpleRun :: Delayed () (Handler ())
|
|
-> IO ()
|
|
simpleRun d = fmap (either ignoreE id) . try $
|
|
runAction d () undefined (\_ -> 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 (Maybe String) -> ServerT api m
|
|
route Proxy ctx server = route (Proxy :: Proxy api) ctx $
|
|
server `addBodyCheck` check
|
|
where
|
|
sym = symbolVal (Proxy :: Proxy sym)
|
|
check = do
|
|
liftIO $ writeIORef delayedTestRef (Just sym)
|
|
_ <- register (writeIORef delayedTestRef Nothing)
|
|
return delayedTestRef
|
|
|
|
type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
|
|
|
|
resApi :: Proxy ResApi
|
|
resApi = Proxy
|
|
|
|
resServer :: Server ResApi
|
|
resServer ref = liftIO $ fmap (maybe "<empty>" T.pack) $ readIORef ref
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Spec
|
|
-------------------------------------------------------------------------------
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
describe "Delayed" $ do
|
|
it "actually runs clean up actions" $ do
|
|
_ <- simpleRun $ delayed (return ()) (Route $ return ())
|
|
cleanUpDone <- isJust <$> readIORef delayedTestRef
|
|
cleanUpDone `shouldBe` False
|
|
it "even with exceptions in serverD" $ do
|
|
_ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
|
|
cleanUpDone <- isJust <$> readIORef delayedTestRef
|
|
cleanUpDone `shouldBe` False
|
|
it "even with routing failure in bodyD" $ do
|
|
_ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
|
|
cleanUpDone <- isJust <$> readIORef delayedTestRef
|
|
cleanUpDone `shouldBe` False
|
|
it "even with exceptions in bodyD" $ do
|
|
_ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
|
|
cleanUpDone <- isJust <$> readIORef delayedTestRef
|
|
cleanUpDone `shouldBe` False
|
|
describe "ResApi" $
|
|
with (return $ serve resApi resServer) $ do
|
|
it "writes and cleanups resources" $ do
|
|
request "GET" "foobar" [] "" `shouldRespondWith` "foobar"
|
|
liftIO $ do
|
|
cleanUpDone <- isJust <$> readIORef delayedTestRef
|
|
cleanUpDone `shouldBe` False
|