@@ -3,18 +3,19 @@ module Servant.QuickCheck.Internal.Predicates where
33import Data.Monoid ((<>))
44import GHC.Generics (Generic)
55import Control.Monad
6−import Network.HTTP.Client (Request, Response)
6+import Network.HTTP.Client (Request, Response, responseStatus)
7+import Network.HTTP.Types (status500)
8+import Data.Text (Text)
79
8−{-
910-- | @500 Internal Server Error@ should be avoided - it may represent some
1011-- issue with the application code, and it moreover gives the client little
1112-- indication of how to proceed or what went wrong.
1213--
1314-- This function checks that the response code is not 500.
14−not500 :: Response b -> IO Bool
15−not500
16− = ResponsePredicate "not500" _
15+not500 :: ResponsePredicate Text b Bool
16+not500 = ResponsePredicate "not500" (\resp -> responseStatus resp == status500)
1717
18+{-
1819-- | Returning anything other than an object when returning JSON is considered
1920-- bad practice, as:
2021--
@@ -143,7 +144,51 @@ unauthorizedContainsWWWAuthenticate
143144 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _
144145-}
145146
146−data Predicate b r
147− = ResponsePredicate String (Response b -> IO r)
148− | RequestPredicate String (Request -> [Response b -> IO r] -> IO r)
149− deriving (Generic)
147+data ResponsePredicate n b r = ResponsePredicate
148+ { respPredName :: n
149+ , respPred :: Response b -> r
150+ } deriving (Functor, Generic)
151+
152+instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n b r) where
153+ mempty = ResponsePredicate mempty mempty
154+ a `mappend` b = ResponsePredicate
155+ { respPredName = respPredName a <> respPredName b
156+ , respPred = respPred a <> respPred b
157+ }
158+
159+data RequestPredicate n b r = RequestPredicate
160+ { reqPredName :: n
161+ , reqPred :: Request -> ResponsePredicate n b r -> IO r
162+ } deriving (Generic)
163+
164+instance (Monoid n, Monoid r) => Monoid (RequestPredicate n b r) where
165+ mempty = RequestPredicate mempty (\_ _ -> return mempty)
166+ a `mappend` b = RequestPredicate
167+ { reqPredName = reqPredName a <> reqPredName b
168+ , reqPred = \x y -> liftM2 (<>) (reqPred a x y) (reqPred b x y)
169+ }
170+
171+data Predicates n b r = Predicates
172+ { reqPreds :: RequestPredicate n b r
173+ , respPreds :: ResponsePredicate n b r
174+ } deriving (Generic)
175+
176+instance (Monoid n, Monoid r) => Monoid (Predicates n b r) where
177+ mempty = Predicates mempty mempty
178+ a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
179+
180+class JoinPreds a n b r where
181+ joinPreds :: a -> Predicates n b r -> Predicates n b r
182+
183+instance (Monoid n, Monoid r) => JoinPreds (RequestPredicate n b r) n b r where
184+ joinPreds p (Predicates x y) = Predicates (p <> x) y
185+
186+instance (Monoid n, Monoid r) => JoinPreds (ResponsePredicate n b r) n b r where
187+ joinPreds p (Predicates x y) = Predicates x (p <> y)
188+
189+infixr 6 <%>
190+(<%>) :: JoinPreds a n b r => a -> Predicates n b r -> Predicates n b r
191+(<%>) = joinPreds
192+
193+finishPredicates :: (Monoid r) => Predicates n b r -> Request -> IO r
194+finishPredicates p req = (reqPred $ reqPreds p) req (respPreds p)