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.IO.Class
import Data.IORef
import Data.Maybe (isJust)
import Data.Proxy
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Servant
@ -27,9 +26,33 @@ 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 (Maybe String)
delayedTestRef = unsafePerformIO $ newIORef Nothing
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
@ -37,8 +60,8 @@ delayed body srv = Delayed
, methodD = return ()
, authD = return ()
, bodyD = do
liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")
_ <- register (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")
liftIO (writeTestResource"hia" >> putStrLn "garbage created")
_ <- register (freeTestResource >> putStrLn "garbage collected")
body
, serverD = \() () _body _req -> srv
}
@ -59,14 +82,14 @@ simpleRun d = fmap (either ignoreE id) . try $
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
type ServerT (Res sym :> api) m = IORef (TestResource 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)
liftIO $ writeTestResource sym
_ <- register freeTestResource
return delayedTestRef
type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
@ -75,7 +98,7 @@ resApi :: Proxy ResApi
resApi = Proxy
resServer :: Server ResApi
resServer ref = liftIO $ fmap (maybe "<empty>" T.pack) $ readIORef ref
resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref
-------------------------------------------------------------------------------
-- Spec
@ -85,25 +108,30 @@ spec :: Spec
spec = do
describe "Delayed" $ do
it "actually runs clean up actions" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (return ()) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with exceptions in serverD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with routing failure in bodyD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with exceptions in bodyD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
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
cleanUpDone <- isJust <$> readIORef delayedTestRef
cleanUpDone `shouldBe` False
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed