@@ -5,13 +5,16 @@ import Data.Aeson (Object, decode)
5import Data.Bifunctor (Bifunctor (..))
5import Data.Bifunctor (Bifunctor (..))
6import qualified Data.ByteString.Lazy as LBS
6import qualified Data.ByteString.Lazy as LBS
7import qualified Data.ByteString as SBS
7import qualified Data.ByteString as SBS
8+import qualified Data.ByteString.Char8 as SBSC
8import Data.CaseInsensitive (mk)
9import Data.CaseInsensitive (mk)
10+import Data.Either (isRight)
11+import Data.List.Split (wordsBy)
9import Data.Monoid ((<>))
12import Data.Monoid ((<>))
10import Data.Text (Text)
13import Data.Text (Text)
11import GHC.Generics (Generic)
14import GHC.Generics (Generic)
12import Network.HTTP.Client (Manager, Request, Response, httpLbs,
15import Network.HTTP.Client (Manager, Request, Response, httpLbs,
13 responseBody, responseStatus, responseHeaders)
16 responseBody, responseStatus, responseHeaders)
14−import Network.HTTP.Types (status500)
17+import Network.HTTP.Types (status500, status405, parseMethod)
16-- | @500 Internal Server Error@ should be avoided - it may represent some
19-- | @500 Internal Server Error@ should be avoided - it may represent some
17-- issue with the application code, and it moreover gives the client little
20-- issue with the application code, and it moreover gives the client little
@@ -52,20 +55,28 @@ createContainsValidLocation :: ResponsePredicate Text Bool
52createContainsValidLocation
55createContainsValidLocation
53 = ResponsePredicate "createContainsValidLocation" (\resp ->
56 = ResponsePredicate "createContainsValidLocation" (\resp ->
55−getsHaveLastModifiedHeader :: Response b -> IO Bool
58+getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
56getsHaveLastModifiedHeader
59getsHaveLastModifiedHeader
57− = ResponsePredicate "getsHaveLastModifiedHeader" _
60+ = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
59-- | When an HTTP request has a method that is not allowed, a 405 response
63-- | When an HTTP request has a method that is not allowed, a 405 response
60-- should be returned. Additionally, it is good practice to return an @Allow@
64-- should be returned. Additionally, it is good practice to return an @Allow@
61-- header with the list of allowed methods.
65-- header with the list of allowed methods.
63-- This function checks that every @405 Method Not Allowed@ response contains
67-- This function checks that every @405 Method Not Allowed@ response contains
64-- an @Allow@ header with a list of standard HTTP methods.
68-- an @Allow@ header with a list of standard HTTP methods.
65−notAllowedContainsAllowHeader :: Response b -> IO Bool
69+notAllowedContainsAllowHeader :: ResponsePredicate Text Bool
66notAllowedContainsAllowHeader
70notAllowedContainsAllowHeader
67− = ResponsePredicate "notAllowedContainsAllowHeader" _
71+ = ResponsePredicate "notAllowedContainsAllowHeader" (\resp ->
68−
72+ if responseStatus resp == status405
73+ then hasValidHeader "Allow" go resp
76+ go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
77+ $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
69-- | When a request contains an @Accept@ header, the server must either return
80-- | When a request contains an @Accept@ header, the server must either return
70-- content in one of the requested representations, or respond with @406 Not
81-- content in one of the requested representations, or respond with @406 Not
71-- Acceptable@.
82-- Acceptable@.
@@ -230,5 +241,7 @@ finishPredicates p req mgr = do
231-- * helpers
242-- * helpers
233−hasHeader :: SBS.ByteString -> Response b -> Bool
244+hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bool
234−hasHeader hdr r = mk hdr `elem` (fst <$> responseHeaders r)
245+hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of