1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
{-# 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.IO.Class
import Control.Monad.Trans.Resource
(register)
import Data.IORef
import Data.Proxy
import GHC.TypeLits
(KnownSymbol, Symbol, symbolVal)
import Network.Wai
(defaultRequest)
import Servant
import Servant.Server.Internal
import Test.Hspec
import Test.Hspec.Wai
(request, shouldRespondWith, with)
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 (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
{ capturesD = \() -> return ()
, methodD = return ()
, authD = return ()
, acceptD = return ()
, contentD = return ()
, paramsD = return ()
, headersD = return ()
, bodyD = \() -> do
liftIO (writeTestResource "hia" >> putStrLn "garbage created")
_ <- register (freeTestResource >> putStrLn "garbage collected")
body
, serverD = \() () () () _body _req -> srv
}
simpleRun :: Delayed () (Handler ())
-> IO ()
simpleRun d = fmap (either ignoreE id) . try $
runAction d () defaultRequest (\_ -> 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 (TestResource String) -> ServerT api m
hoistServerWithContext _ nc nt s = hoistServerWithContext (Proxy :: Proxy api) nc nt . s
route Proxy ctx server = route (Proxy :: Proxy api) ctx $
addBodyCheck server (return ()) check
where
sym = symbolVal (Proxy :: Proxy sym)
check () = do
liftIO $ writeTestResource sym
_ <- register freeTestResource
return delayedTestRef
type ResApi = "foobar" :> Res "foobar" :> Get '[PlainText] T.Text
resApi :: Proxy ResApi
resApi = Proxy
resServer :: Server ResApi
resServer ref = liftIO $ fmap (fromTestResource "<wrong>" T.pack) $ readIORef ref
-------------------------------------------------------------------------------
-- Spec
-------------------------------------------------------------------------------
spec :: Spec
spec = do
describe "Delayed" $ do
it "actually runs clean up actions" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (return ()) (Route $ return ())
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with exceptions in serverD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with routing failure in bodyD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
it "even with exceptions in bodyD" $ do
liftIO initTestResource
_ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
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
res <- readIORef delayedTestRef
res `shouldBe` TestResourceFreed
|
