@@ -15,7 +15,6 @@ import Control.Exception hiding (Handler)
1515import Control.Monad.Trans.Resource (register)
1616import Control.Monad.IO.Class
1717import Data.IORef
18−import Data.Maybe (isJust)
1918import Data.Proxy
2019import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
2120import Servant
@@ -27,9 +26,33 @@ import qualified Data.Text as T
2726
2827import System.IO.Unsafe (unsafePerformIO)
2928
29+data TestResource x
30+ = TestResourceNone
31+ | TestResource x
32+ | TestResourceFreed
33+ | TestResourceError
34+ deriving (Eq, Show)
35+
3036-- Let's not write to the filesystem
31−delayedTestRef :: IORef (Maybe String)
32−delayedTestRef = unsafePerformIO $ newIORef Nothing
37+delayedTestRef :: IORef (TestResource String)
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
3356
3457delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
3558delayed body srv = Delayed
@@ -37,8 +60,8 @@ delayed body srv = Delayed
3760 , methodD = return ()
3861 , authD = return ()
3962 , bodyD = do
40− liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")
41− _ <- register (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")
63+ liftIO (writeTestResource"hia" >> putStrLn "garbage created")
64+ _ <- register (freeTestResource >> putStrLn "garbage collected")
4265 body
4366 , serverD = \() () _body _req -> srv
4467 }
@@ -59,14 +82,14 @@ simpleRun d = fmap (either ignoreE id) . try $
5982data Res (sym :: Symbol)
6083
6184instance (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
6386 route Proxy ctx server = route (Proxy :: Proxy api) ctx $
6487 server `addBodyCheck` check
6588 where
6689 sym = symbolVal (Proxy :: Proxy sym)
6790 check = do
68− liftIO $ writeIORef delayedTestRef (Just sym)
69− _ <- register (writeIORef delayedTestRef Nothing)
91+ liftIO $ writeTestResource sym
92+ _ <- register freeTestResource
7093 return delayedTestRef
7194
7295type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
@@ -75,7 +98,7 @@ resApi :: Proxy ResApi
7598resApi = Proxy
7699
77100resServer :: Server ResApi
78−resServer ref = liftIO $ fmap (maybe "<empty>" T.pack) $ readIORef ref
101+resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref
79102
80103-------------------------------------------------------------------------------
81104-- Spec
@@ -85,25 +108,30 @@ spec :: Spec
85108spec = do
86109 describe "Delayed" $ do
87110 it "actually runs clean up actions" $ do
111+ liftIO initTestResource
88112 _ <- simpleRun $ delayed (return ()) (Route $ return ())
89− cleanUpDone <- isJust <$> readIORef delayedTestRef
90− cleanUpDone `shouldBe` False
113+ res <- readIORef delayedTestRef
114+ res `shouldBe` TestResourceFreed
91115 it "even with exceptions in serverD" $ do
116+ liftIO initTestResource
92117 _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
93− cleanUpDone <- isJust <$> readIORef delayedTestRef
94− cleanUpDone `shouldBe` False
118+ res <- readIORef delayedTestRef
119+ res `shouldBe` TestResourceFreed
95120 it "even with routing failure in bodyD" $ do
121+ liftIO initTestResource
96122 _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
97− cleanUpDone <- isJust <$> readIORef delayedTestRef
98− cleanUpDone `shouldBe` False
123+ res <- readIORef delayedTestRef
124+ res `shouldBe` TestResourceFreed
99125 it "even with exceptions in bodyD" $ do
126+ liftIO initTestResource
100127 _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
101− cleanUpDone <- isJust <$> readIORef delayedTestRef
102− cleanUpDone `shouldBe` False
128+ res <- readIORef delayedTestRef
129+ res `shouldBe` TestResourceFreed
103130 describe "ResApi" $
104131 with (return $ serve resApi resServer) $ do
105132 it "writes and cleanups resources" $ do
133+ liftIO initTestResource
106134 request "GET" "foobar" [] "" `shouldRespondWith` "foobar"
107135 liftIO $ do
108− cleanUpDone <- isJust <$> readIORef delayedTestRef
109− cleanUpDone `shouldBe` False
136+ res <- readIORef delayedTestRef
137+ res `shouldBe` TestResourceFreed