git.iko.soy/servant-quickcheck
on bf4efbc help sign in
servant-quickcheck/src/Servant/QuickCheck/Internal/QuickCheck.hs
168 lines 7.8 kB history raw
1-- | This module contains wrappers around lower-level functionality.
2module Servant.QuickCheck.Internal.QuickCheck where
4import Control.Concurrent (threadDelay)
5import Control.Concurrent.MVar (modifyMVar_, readMVar)
6import Control.Monad (replicateM_)
7import Data.Proxy (Proxy)
8import Data.Void (Void)
9import Network.HTTP.Client (Manager, defaultManagerSettings,
10 newManager)
11import Network.HTTP.Client (managerModifyRequest, getUri)
12import Network.Wai.Handler.Warp (withApplication)
13import Servant (HasServer, Server, serve)
14import Servant.Client (BaseUrl (..), Client, HasClient,
15 Scheme (..), ServantError, client)
16import System.IO (hPutStrLn, hFlush)
17import System.IO.Temp (withSystemTempFile)
18import System.Mem (performGC)
19import System.Process (callCommand)
20import Test.Hspec (Expectation, expectationFailure)
21import Test.QuickCheck (Args (..), Property, Result (..),
22 Testable, property,
23 quickCheckWithResult, stdArgs)
25import Servant.QuickCheck.Internal.Testable
26import Servant.QuickCheck.Internal.Predicates
27import Servant.QuickCheck.Internal.Benchmarking
30-- | Start a servant application on an open port, run the provided function,
31-- then stop the application.
32withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
33 -> (BaseUrl -> IO r) -> IO r
34withServantServer api server t
35 = withApplication (return . serve api =<< server) $ \port ->
36 t (BaseUrl Http "localhost" port "")
38-- | A QuickCheck 'Property' that randomly generates arguments (captures, query
39-- params, request bodies, headers, etc.) expected by endpoints of a server,
40-- and makes requests to the servers running in the two provided URLs in the
41-- same order, failing if they do not return the same response.
42--
43-- Evidently, if the behaviour of the server is expected to be
44-- non-deterministic, this function may produce spurious failures.
45--
46-- Note that this QuickCheck 'Property' does IO; interleaving it with other IO
47-- actions will not work. It is provided so that it can be used with QuickCheck
48-- functions such as 'quickCheckWith'. For most use cases, you should use
49-- @serversEqual@ or @servantServersEqual@.
50serversEqualProperty :: (HasClient a, Testable (ShouldMatch (Client a)))
51 => Proxy a -> Manager -> BaseUrl -> BaseUrl -> Property
52serversEqualProperty api mgr burl1 burl2
53 = property $ ShouldMatch
54 { smClient = client api
55 , smManager = mgr
56 , smBaseUrls = (burl1, burl2)
57 }
59-- | Check that the two servers running under the provided @BaseUrl@s behave
60-- identically by randomly generating arguments (captures, query params, request bodies,
61-- headers, etc.) expected by the server. If, given the same request, the
62-- response is not the same (according to the definition of @==@ for the return
63-- datatype), the 'Expectation' fails, printing the counterexample.
64--
65-- The @Int@ argument specifies maximum number of test cases to generate and
66-- run.
67--
68-- Evidently, if the behaviour of the server is expected to be
69-- non-deterministic, this function may produce spurious failures.
70serversEqual :: (HasClient a, Testable (ShouldMatch (Client a)))
71 => Proxy a -> BaseUrl -> BaseUrl -> Int -> Expectation
72serversEqual api burl1 burl2 tries = do
73 mgr <- managerWithStoredReq
74 let args = stdArgs { chatty = False, maxSuccess = tries }
75 res <- quickCheckWithResult args $ serversEqualProperty api mgr burl1 burl2
76 case res of
77 Success _ _ _ -> return ()
78 _ -> prettyErr >>= expectationFailure
81serverSatisfiesProperty :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
82 => Proxy a -> Manager -> BaseUrl -> Predicates filt -> Predicates exp -> Property
83serverSatisfiesProperty api mgr burl filters expect = do
84 property $ ShouldSatisfy
85 { ssVal = client api
86 , ssFilter = filters
87 , ssExpect = expect
88 , ssManager = mgr
89 , ssBaseUrl = burl
90 }
92-- | Check that a server's responses satisfies certain properties.
93serverSatisfies :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
94 => Proxy a -> BaseUrl -> Predicates filt -> Predicates exp
95 -> Int -> Expectation
96serverSatisfies api burl filters expect tries = do
97 mgr <- managerWithStoredReq
98 let args = stdArgs { chatty = False, maxSuccess = tries }
99 res <- quickCheckWithResult args $ serverSatisfiesProperty api mgr burl filters expect
100 case res of
101 Success _ _ _ -> return ()
102 GaveUp n _ _ -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
103 _ -> prettyErr >>= expectationFailure
105-- | Check that the two servers running under the provided @BaseUrl@s do not
106-- behave identically.
107--
108-- As with @serversEqualProperty@, non-determinism in the servers will likely
109-- result in failures that may not be significant.
110serversUnequal :: (HasClient a, Testable (ShouldMatch (Client a)))
111 => Proxy a -> BaseUrl -> BaseUrl -> Int -> Expectation
112serversUnequal api burl1 burl2 tries = do
113 mgr <- managerWithStoredReq
114 let args = stdArgs { chatty = False, maxSuccess = tries }
115 res <- quickCheckWithResult args $ serversEqualProperty api mgr burl1 burl2
116 case res of
117 Success _ _ _ -> prettyErr >>= expectationFailure
118 _ -> return ()
120serverDoesntSatisfy :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
121 => Proxy a -> BaseUrl -> Predicates filt -> Predicates exp
122 -> Int -> Expectation
123serverDoesntSatisfy api burl filters expect tries = do
124 mgr <- managerWithStoredReq
125 let args = stdArgs { chatty = False, maxSuccess = tries }
126 res <- quickCheckWithResult args $ serverSatisfiesProperty api mgr burl filters expect
127 case res of
128 Success _ _ _ -> prettyErr >>= expectationFailure
129 _ -> return ()
131-- | Benchmarks a server with arbitrary requests using 'wrk'.
132--
133-- When using this, you should compile your program with '-threaded'.
134-- Moreover, 'wrk' must be in the @$PATH@.
135--
136-- Note that this function is still very experimental, and it's behaviour will
137-- likely change.
138serverBenchmark ::
139 (HasClient a , Testable (ShouldSatisfy '[] '[Either ServantError Void] (Client a)))
140 => Proxy a -> BaseUrl -> BenchOptions -> IO ()
141serverBenchmark api burl opts = replicateM_ (noOfTests opts) go
142 where
143 go = do
144 let alwaysTrue = addLeftPredicate (const True) emptyPredicates
145 serverSatisfies api burl emptyPredicates alwaysTrue 1
146 Just (r, _) <- readMVar currentReq
147 withSystemTempFile "wrkscript.lua" $ \f h -> do
148 let url = show $ getUri r
149 s = mkScript $ reqToWrk r
150 c = "wrk -c" ++ show (connections opts)
151 ++ " -d" ++ show (duration opts) ++ "s "
152 ++ " -t" ++ show (threads opts)
153 ++ " -s \"" ++ f ++ "\" "
154 ++ " --latency "
155 ++ url
156 hPutStrLn h s
157 hFlush h
158 callCommand c
159 -- While running wrk and the server on the same machine make the
160 -- results much less meaningful, this ameliorates the situation
161 -- somewhat.
162 performGC
163 threadDelay 1000
165managerWithStoredReq :: IO Manager
166managerWithStoredReq = newManager defaultManagerSettings { managerModifyRequest = go }
167 where go req = modifyMVar_ currentReq (addReq req) >> return req
168 addReq req _ = return $ Just (req, "")