eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

More robust testing, via resource state machine

Browse Source
This commit is contained in:
Oleg Grenrus 2017-01-19 00:55:04 +02:00
parent d4fe0e582a
commit 6527937e27
1 changed files with 47 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs
View File

@ -15,7 +15,6 @@ import Control.Exception hiding (Handler)
import Control.Monad.Trans.Resource (register) import Control.Monad.Trans.Resource (register)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.IORef import Data.IORef
import Data.Maybe (isJust)
import Data.Proxy import Data.Proxy
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Servant import Servant
@ -27,9 +26,33 @@ import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
data TestResource x
= TestResourceNone
| TestResource x
| TestResourceFreed
| TestResourceError
deriving (Eq, Show)
-- Let's not write to the filesystem -- Let's not write to the filesystem
delayedTestRef :: IORef (Maybe String) delayedTestRef :: IORef (TestResource String)
delayedTestRef = unsafePerformIO $ newIORef Nothing 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 :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
delayed body srv = Delayed delayed body srv = Delayed
@ -37,8 +60,8 @@ delayed body srv = Delayed
, methodD = return () , methodD = return ()
, authD = return () , authD = return ()
, bodyD = do , bodyD = do
liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created") liftIO (writeTestResource"hia" >> putStrLn "garbage created")
_ <- register (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected") _ <- register (freeTestResource >> putStrLn "garbage collected")
body body
, serverD = \() () _body _req -> srv , serverD = \() () _body _req -> srv
} }
@ -59,14 +82,14 @@ simpleRun d = fmap (either ignoreE id) . try $
data Res (sym :: Symbol) data Res (sym :: Symbol)
instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
type ServerT (Res sym :> api) m = IORef (Maybe String) -> ServerT api m type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m
route Proxy ctx server = route (Proxy :: Proxy api) ctx $ route Proxy ctx server = route (Proxy :: Proxy api) ctx $
server `addBodyCheck` check server `addBodyCheck` check
where where
sym = symbolVal (Proxy :: Proxy sym) sym = symbolVal (Proxy :: Proxy sym)
check = do check = do
liftIO $ writeIORef delayedTestRef (Just sym) liftIO $ writeTestResource sym
_ <- register (writeIORef delayedTestRef Nothing) _ <- register freeTestResource
return delayedTestRef return delayedTestRef
type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
@ -75,7 +98,7 @@ resApi :: Proxy ResApi
resApi = Proxy resApi = Proxy
resServer :: Server ResApi resServer :: Server ResApi
resServer ref = liftIO $ fmap (maybe "<empty>" T.pack) $ readIORef ref resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Spec -- Spec
@ -85,25 +108,30 @@ spec :: Spec
spec = do spec = do
describe "Delayed" $ do describe "Delayed" $ do
it "actually runs clean up actions" $ do it "actually runs clean up actions" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (return ()) (Route $ return ()) _ <- simpleRun $ delayed (return ()) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef res <- readIORef delayedTestRef
cleanUpDone `shouldBe` False res `shouldBe` TestResourceFreed
it "even with exceptions in serverD" $ do it "even with exceptions in serverD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero) _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
cleanUpDone <- isJust <$> readIORef delayedTestRef res <- readIORef delayedTestRef
cleanUpDone `shouldBe` False res `shouldBe` TestResourceFreed
it "even with routing failure in bodyD" $ do it "even with routing failure in bodyD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ()) _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef res <- readIORef delayedTestRef
cleanUpDone `shouldBe` False res `shouldBe` TestResourceFreed
it "even with exceptions in bodyD" $ do it "even with exceptions in bodyD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ()) _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef res <- readIORef delayedTestRef
cleanUpDone `shouldBe` False res `shouldBe` TestResourceFreed
describe "ResApi" $ describe "ResApi" $
with (return $ serve resApi resServer) $ do with (return $ serve resApi resServer) $ do
it "writes and cleanups resources" $ do it "writes and cleanups resources" $ do
liftIO initTestResource
request "GET" "foobar" [] "" `shouldRespondWith` "foobar" request "GET" "foobar" [] "" `shouldRespondWith` "foobar"
liftIO $ do liftIO $ do
cleanUpDone <- isJust <$> readIORef delayedTestRef res <- readIORef delayedTestRef
cleanUpDone `shouldBe` False res `shouldBe` TestResourceFreed