@@ -5,6 +5,7 @@ import GHC.Generics (Generic)
55import Control.Monad
66import Network.HTTP.Client (Request, Response, responseStatus)
77import Network.HTTP.Types (status500)
8+import qualified Data.ByteString.Lazy as LBS
89import Data.Text (Text)
910
1011-- | @500 Internal Server Error@ should be avoided - it may represent some
@@ -12,8 +13,9 @@ import Data.Text (Text)
1213-- indication of how to proceed or what went wrong.
1314--
1415-- This function checks that the response code is not 500.
15−not500 :: ResponsePredicate Text b Bool
16−not500 = ResponsePredicate "not500" (\resp -> responseStatus resp == status500)
16+not500 :: ResponsePredicate Text [Text]
17+not500 = ResponsePredicate "not500" (\resp ->
18+ if responseStatus resp == status500 then ["not500"] else [])
1719
1820{-
1921-- | Returning anything other than an object when returning JSON is considered
@@ -143,52 +145,66 @@ unauthorizedContainsWWWAuthenticate :: Predicate b Bool
143145unauthorizedContainsWWWAuthenticate
144146 = ResponsePredicate "unauthorizedContainsWWWAuthenticate" _
145147-}
148+-- * Predicate logic
146149
147−data ResponsePredicate n b r = ResponsePredicate
150+-- The idea with all this footwork is to not waste any requests. Rather than
151+-- generating new requests and only applying one predicate to the response, we
152+-- apply as many predicates as possible.
153+--
154+-- Still, this is all kind of ugly.
155+
156+data ResponsePredicate n r = ResponsePredicate
148157 { respPredName :: n
149− , respPred :: Response b -> r
158+ , respPred :: Response LBS.ByteString -> r
150159 } deriving (Functor, Generic)
151160
152−instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n b r) where
161+instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
153162 mempty = ResponsePredicate mempty mempty
154163 a `mappend` b = ResponsePredicate
155164 { respPredName = respPredName a <> respPredName b
156165 , respPred = respPred a <> respPred b
157166 }
158167
159−data RequestPredicate n b r = RequestPredicate
168+data RequestPredicate n r = RequestPredicate
160169 { reqPredName :: n
161− , reqPred :: Request -> ResponsePredicate n b r -> IO r
162− } deriving (Generic)
170+ , reqResps :: Request -> IO [Response LBS.ByteString]
171+ , reqPred :: ResponsePredicate n r
172+ } deriving (Generic, Functor)
163173
164−instance (Monoid n, Monoid r) => Monoid (RequestPredicate n b r) where
165− mempty = RequestPredicate mempty (\_ _ -> return mempty)
174+instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
175+ mempty = RequestPredicate mempty (\_ -> return mempty) mempty
166176 a `mappend` b = RequestPredicate
167177 { reqPredName = reqPredName a <> reqPredName b
168− , reqPred = \x y -> liftM2 (<>) (reqPred a x y) (reqPred b x y)
178+ , reqResps = \x -> liftM2 (<>) (reqResps a x) (reqResps b x)
179+ , reqPred = reqPred a <> reqPred b
169180 }
170181
171−data Predicates n b r = Predicates
172− { reqPreds :: RequestPredicate n b r
173− , respPreds :: ResponsePredicate n b r
174− } deriving (Generic)
182+data Predicates n r = Predicates
183+ { reqPreds :: RequestPredicate n r
184+ , respPreds :: ResponsePredicate n r
185+ } deriving (Generic, Functor)
175186
176−instance (Monoid n, Monoid r) => Monoid (Predicates n b r) where
187+instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
177188 mempty = Predicates mempty mempty
178189 a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
179190
180−class JoinPreds a n b r where
181− joinPreds :: a -> Predicates n b r -> Predicates n b r
182191
183−instance (Monoid n, Monoid r) => JoinPreds (RequestPredicate n b r) n b r where
192+
193+class JoinPreds a where
194+ joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
195+
196+instance JoinPreds (RequestPredicate Text Bool) where
184197 joinPreds p (Predicates x y) = Predicates (p <> x) y
185198
186−instance (Monoid n, Monoid r) => JoinPreds (ResponsePredicate n b r) n b r where
199+instance JoinPreds (ResponsePredicate Text Bool) where
187200 joinPreds p (Predicates x y) = Predicates x (p <> y)
188201
189202infixr 6 <%>
190203(<%>) :: JoinPreds a n b r => a -> Predicates n b r -> Predicates n b r
191204(<%>) = joinPreds
192205
193−finishPredicates :: (Monoid r) => Predicates n b r -> Request -> IO r
194−finishPredicates p req = (reqPred $ reqPreds p) req (respPreds p)
206+finishPredicates :: Predicates [Text] [Text] -> Request -> IO [Text]
207+finishPredicates p req = do
208+ resps <- reqResps (reqPreds p) req
209+ let preds = reqPred (reqPreds p) <> respPreds p
210+ return $ mconcat [respPred preds r | r <- resps ]