@@ -5,13 +5,16 @@ import Data.Aeson (Object, decode)
55import Data.Bifunctor (Bifunctor (..))
66import qualified Data.ByteString.Lazy as LBS
77import qualified Data.ByteString as SBS
8+import qualified Data.ByteString.Char8 as SBSC
89import Data.CaseInsensitive (mk)
10+import Data.Either (isRight)
11+import Data.List.Split (wordsBy)
912import Data.Monoid ((<>))
1013import Data.Text (Text)
1114import GHC.Generics (Generic)
1215import Network.HTTP.Client (Manager, Request, Response, httpLbs,
1316 responseBody, responseStatus, responseHeaders)
14−import Network.HTTP.Types (status500)
17+import Network.HTTP.Types (status500, status405, parseMethod)
1518
1619-- | @500 Internal Server Error@ should be avoided - it may represent some
1720-- issue with the application code, and it moreover gives the client little
@@ -52,20 +55,28 @@ createContainsValidLocation :: ResponsePredicate Text Bool
5255createContainsValidLocation
5356 = ResponsePredicate "createContainsValidLocation" (\resp ->
5457
55−getsHaveLastModifiedHeader :: Response b -> IO Bool
58+getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
5659getsHaveLastModifiedHeader
57− = ResponsePredicate "getsHaveLastModifiedHeader" _
60+ = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
5861
62+-}
5963-- | When an HTTP request has a method that is not allowed, a 405 response
6064-- should be returned. Additionally, it is good practice to return an @Allow@
6165-- header with the list of allowed methods.
6266--
6367-- This function checks that every @405 Method Not Allowed@ response contains
6468-- an @Allow@ header with a list of standard HTTP methods.
65−notAllowedContainsAllowHeader :: Response b -> IO Bool
69+notAllowedContainsAllowHeader :: ResponsePredicate Text Bool
6670notAllowedContainsAllowHeader
67− = ResponsePredicate "notAllowedContainsAllowHeader" _
68−
71+ = ResponsePredicate "notAllowedContainsAllowHeader" (\resp ->
72+ if responseStatus resp == status405
73+ then hasValidHeader "Allow" go resp
74+ else True)
75+ where
76+ go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
77+ $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
78+
79+ {-
6980-- | When a request contains an @Accept@ header, the server must either return
7081-- content in one of the requested representations, or respond with @406 Not
7182-- Acceptable@.
@@ -230,5 +241,7 @@ finishPredicates p req mgr = do
230241
231242-- * helpers
232243
233−hasHeader :: SBS.ByteString -> Response b -> Bool
234−hasHeader hdr r = mk hdr `elem` (fst <$> responseHeaders r)
244+hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bool
245+hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
246+ Nothing -> False
247+ Just v -> p v