git.iko.soy/typeable/servant
on master help sign in
More robust testing, via resource state machine
6527937Oleg Grenrus
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs+47−19
compare with master
unifiedsplit
@@ -15,7 +15,6 @@ import Control.Exception hiding (Handler)
15import Control.Monad.Trans.Resource (register)
15import Control.Monad.Trans.Resource (register)
16import Control.Monad.IO.Class
16import Control.Monad.IO.Class
17import Data.IORef
17import Data.IORef
18−import Data.Maybe (isJust)
19import Data.Proxy
18import Data.Proxy
20import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
19import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
21import Servant
20import Servant
@@ -27,9 +26,33 @@ import qualified Data.Text as T
27
26
28import System.IO.Unsafe (unsafePerformIO)
27import System.IO.Unsafe (unsafePerformIO)
29
28
29+data TestResource x
30+ = TestResourceNone
31+ | TestResource x
32+ | TestResourceFreed
33+ | TestResourceError
34+ deriving (Eq, Show)
35+
30-- Let's not write to the filesystem
36-- Let's not write to the filesystem
31−delayedTestRef :: IORef (Maybe String)
37+delayedTestRef :: IORef (TestResource String)
32−delayedTestRef = unsafePerformIO $ newIORef Nothing
38+delayedTestRef = unsafePerformIO $ newIORef TestResourceNone
39+
40+fromTestResource :: a -> (b -> a) -> TestResource b -> a
41+fromTestResource _ f (TestResource x) = f x
42+fromTestResource x _ _ = x
43+
44+initTestResource :: IO ()
45+initTestResource = writeIORef delayedTestRef TestResourceNone
46+
47+writeTestResource :: String -> IO ()
48+writeTestResource x = modifyIORef delayedTestRef $ \r -> case r of
49+ TestResourceNone -> TestResource x
50+ _ -> TestResourceError
51+
52+freeTestResource :: IO ()
53+freeTestResource = modifyIORef delayedTestRef $ \r -> case r of
54+ TestResource _ -> TestResourceFreed
55+ _ -> TestResourceError
33
56
34delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
57delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
35delayed body srv = Delayed
58delayed body srv = Delayed
@@ -37,8 +60,8 @@ delayed body srv = Delayed
37 , methodD = return ()
60 , methodD = return ()
38 , authD = return ()
61 , authD = return ()
39 , bodyD = do
62 , bodyD = do
40− liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")
63+ liftIO (writeTestResource"hia" >> putStrLn "garbage created")
41− _ <- register (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")
64+ _ <- register (freeTestResource >> putStrLn "garbage collected")
42 body
65 body
43 , serverD = \() () _body _req -> srv
66 , serverD = \() () _body _req -> srv
44 }
67 }
@@ -59,14 +82,14 @@ simpleRun d = fmap (either ignoreE id) . try $
59data Res (sym :: Symbol)
82data Res (sym :: Symbol)
60
83
61instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
84instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
62− type ServerT (Res sym :> api) m = IORef (Maybe String) -> ServerT api m
85+ type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m
63 route Proxy ctx server = route (Proxy :: Proxy api) ctx $
86 route Proxy ctx server = route (Proxy :: Proxy api) ctx $
64 server `addBodyCheck` check
87 server `addBodyCheck` check
65 where
88 where
66 sym = symbolVal (Proxy :: Proxy sym)
89 sym = symbolVal (Proxy :: Proxy sym)
67 check = do
90 check = do
68− liftIO $ writeIORef delayedTestRef (Just sym)
91+ liftIO $ writeTestResource sym
69− _ <- register (writeIORef delayedTestRef Nothing)
92+ _ <- register freeTestResource
70 return delayedTestRef
93 return delayedTestRef
71
94
72type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
95type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
@@ -75,7 +98,7 @@ resApi :: Proxy ResApi
75resApi = Proxy
98resApi = Proxy
76
99
77resServer :: Server ResApi
100resServer :: Server ResApi
78−resServer ref = liftIO $ fmap (maybe "<empty>" T.pack) $ readIORef ref
101+resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref
79
102
80-------------------------------------------------------------------------------
103-------------------------------------------------------------------------------
81-- Spec
104-- Spec
@@ -85,25 +108,30 @@ spec :: Spec
85spec = do
108spec = do
86 describe "Delayed" $ do
109 describe "Delayed" $ do
87 it "actually runs clean up actions" $ do
110 it "actually runs clean up actions" $ do
111+ liftIO initTestResource
88 _ <- simpleRun $ delayed (return ()) (Route $ return ())
112 _ <- simpleRun $ delayed (return ()) (Route $ return ())
89− cleanUpDone <- isJust <$> readIORef delayedTestRef
113+ res <- readIORef delayedTestRef
90− cleanUpDone `shouldBe` False
114+ res `shouldBe` TestResourceFreed
91 it "even with exceptions in serverD" $ do
115 it "even with exceptions in serverD" $ do
116+ liftIO initTestResource
92 _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
117 _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
93− cleanUpDone <- isJust <$> readIORef delayedTestRef
118+ res <- readIORef delayedTestRef
94− cleanUpDone `shouldBe` False
119+ res `shouldBe` TestResourceFreed
95 it "even with routing failure in bodyD" $ do
120 it "even with routing failure in bodyD" $ do
121+ liftIO initTestResource
96 _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
122 _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
97− cleanUpDone <- isJust <$> readIORef delayedTestRef
123+ res <- readIORef delayedTestRef
98− cleanUpDone `shouldBe` False
124+ res `shouldBe` TestResourceFreed
99 it "even with exceptions in bodyD" $ do
125 it "even with exceptions in bodyD" $ do
126+ liftIO initTestResource
100 _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
127 _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
101− cleanUpDone <- isJust <$> readIORef delayedTestRef
128+ res <- readIORef delayedTestRef
102− cleanUpDone `shouldBe` False
129+ res `shouldBe` TestResourceFreed
103 describe "ResApi" $
130 describe "ResApi" $
104 with (return $ serve resApi resServer) $ do
131 with (return $ serve resApi resServer) $ do
105 it "writes and cleanups resources" $ do
132 it "writes and cleanups resources" $ do
133+ liftIO initTestResource
106 request "GET" "foobar" [] "" `shouldRespondWith` "foobar"
134 request "GET" "foobar" [] "" `shouldRespondWith` "foobar"
107 liftIO $ do
135 liftIO $ do
108− cleanUpDone <- isJust <$> readIORef delayedTestRef
136+ res <- readIORef delayedTestRef
109− cleanUpDone `shouldBe` False
137+ res `shouldBe` TestResourceFreed