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

{-# 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