diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,6 +1,6 @@ Name: HTTP -Version: 4000.3.14 -Cabal-Version: >= 1.8 +Version: 4000.3.15 +Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 License-file: LICENSE @@ -56,7 +56,7 @@ Extra-Source-Files: CHANGES -tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 +tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 Source-Repository head type: git @@ -109,11 +109,12 @@ -- note the test harness constraints should be kept in sync with these -- where dependencies are shared - Build-depends: base >= 4.3.0.0 && < 4.14, parsec >= 2.0 && < 3.2 + Build-depends: base >= 4.3.0.0 && < 4.15, parsec >= 2.0 && < 3.2 Build-depends: array >= 0.3.0.2 && < 0.6, bytestring >= 0.9.1.5 && < 0.11 - Build-depends: time >= 1.1.2.3 && < 1.10 + Build-depends: time >= 1.1.2.3 && < 1.11 - Extensions: FlexibleInstances + default-language: Haskell98 + default-extensions: FlexibleInstances if flag(mtl1) Build-depends: mtl >= 1.1.1.0 && < 1.2 @@ -130,11 +131,12 @@ ghc-options: -Werror if os(windows) - Build-depends: Win32 >= 2.2.0.0 && < 2.9 + Build-depends: Win32 >= 2.2.0.0 && < 2.10 Test-Suite test type: exitcode-stdio-1.0 + default-language: Haskell98 hs-source-dirs: test main-is: httpTests.hs @@ -142,6 +144,8 @@ Httpd UnitTests + ghc-options: -Wall + -- note: version constraints for dependencies shared with the library -- should be the same build-depends: HTTP, @@ -151,7 +155,7 @@ bytestring >= 0.9.1.5 && < 0.11, deepseq >= 1.3.0.0 && < 1.5, pureMD5 >= 0.2.4 && < 2.2, - base >= 4.3.0.0 && < 4.14, + base >= 4.3.0.0 && < 4.15, split >= 0.1.3 && < 0.3, test-framework >= 0.2.0 && < 0.9, test-framework-hunit >= 0.3.0 && <0.4 diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs --- a/Network/HTTP/Headers.hs +++ b/Network/HTTP/Headers.hs @@ -130,7 +130,162 @@ | HdrContentTransferEncoding -- | Allows for unrecognised or experimental headers. | HdrCustom String -- not in header map below. - deriving(Eq) + +instance Eq HeaderName where + HdrCustom a == HdrCustom b = (fmap toLower a) == (fmap toLower b) + HdrCacheControl == HdrCacheControl = True + HdrCacheControl == _ = False + _ == HdrCacheControl = False + HdrConnection == HdrConnection = True + HdrConnection == _ = False + _ == HdrConnection = False + HdrDate == HdrDate = True + HdrDate == _ = False + _ == HdrDate = False + HdrPragma == HdrPragma = True + HdrPragma == _ = False + _ == HdrPragma = False + HdrTransferEncoding == HdrTransferEncoding = True + HdrTransferEncoding == _ = False + _ == HdrTransferEncoding = False + HdrUpgrade == HdrUpgrade = True + HdrUpgrade == _ = False + _ == HdrUpgrade = False + HdrVia == HdrVia = True + HdrVia == _ = False + _ == HdrVia = False + HdrAccept == HdrAccept = True + HdrAccept == _ = False + _ == HdrAccept = False + HdrAcceptCharset == HdrAcceptCharset = True + HdrAcceptCharset == _ = False + _ == HdrAcceptCharset = False + HdrAcceptEncoding == HdrAcceptEncoding = True + HdrAcceptEncoding == _ = False + _ == HdrAcceptEncoding = False + HdrAcceptLanguage == HdrAcceptLanguage = True + HdrAcceptLanguage == _ = False + _ == HdrAcceptLanguage = False + HdrAuthorization == HdrAuthorization = True + HdrAuthorization == _ = False + _ == HdrAuthorization = False + HdrCookie == HdrCookie = True + HdrCookie == _ = False + _ == HdrCookie = False + HdrExpect == HdrExpect = True + HdrExpect == _ = False + _ == HdrExpect = False + HdrFrom == HdrFrom = True + HdrFrom == _ = False + _ == HdrFrom = False + HdrHost == HdrHost = True + HdrHost == _ = False + _ == HdrHost = False + HdrIfModifiedSince == HdrIfModifiedSince = True + HdrIfModifiedSince == _ = False + _ == HdrIfModifiedSince = False + HdrIfMatch == HdrIfMatch = True + HdrIfMatch == _ = False + _ == HdrIfMatch = False + HdrIfNoneMatch == HdrIfNoneMatch = True + HdrIfNoneMatch == _ = False + _ == HdrIfNoneMatch = False + HdrIfRange == HdrIfRange = True + HdrIfRange == _ = False + _ == HdrIfRange = False + HdrIfUnmodifiedSince == HdrIfUnmodifiedSince = True + HdrIfUnmodifiedSince == _ = False + _ == HdrIfUnmodifiedSince = False + HdrMaxForwards == HdrMaxForwards = True + HdrMaxForwards == _ = False + _ == HdrMaxForwards = False + HdrProxyAuthorization == HdrProxyAuthorization = True + HdrProxyAuthorization == _ = False + _ == HdrProxyAuthorization = False + HdrRange == HdrRange = True + HdrRange == _ = False + _ == HdrRange = False + HdrReferer == HdrReferer = True + HdrReferer == _ = False + _ == HdrReferer = False + HdrUserAgent == HdrUserAgent = True + HdrUserAgent == _ = False + _ == HdrUserAgent = False + HdrAge == HdrAge = True + HdrAge == _ = False + _ == HdrAge = False + HdrLocation == HdrLocation = True + HdrLocation == _ = False + _ == HdrLocation = False + HdrProxyAuthenticate == HdrProxyAuthenticate = True + HdrProxyAuthenticate == _ = False + _ == HdrProxyAuthenticate = False + HdrPublic == HdrPublic = True + HdrPublic == _ = False + _ == HdrPublic = False + HdrRetryAfter == HdrRetryAfter = True + HdrRetryAfter == _ = False + _ == HdrRetryAfter = False + HdrServer == HdrServer = True + HdrServer == _ = False + _ == HdrServer = False + HdrSetCookie == HdrSetCookie = True + HdrSetCookie == _ = False + _ == HdrSetCookie = False + HdrTE == HdrTE = True + HdrTE == _ = False + _ == HdrTE = False + HdrTrailer == HdrTrailer = True + HdrTrailer == _ = False + _ == HdrTrailer = False + HdrVary == HdrVary = True + HdrVary == _ = False + _ == HdrVary = False + HdrWarning == HdrWarning = True + HdrWarning == _ = False + _ == HdrWarning = False + HdrWWWAuthenticate == HdrWWWAuthenticate = True + HdrWWWAuthenticate == _ = False + _ == HdrWWWAuthenticate = False + HdrAllow == HdrAllow = True + HdrAllow == _ = False + _ == HdrAllow = False + HdrContentBase == HdrContentBase = True + HdrContentBase == _ = False + _ == HdrContentBase = False + HdrContentEncoding == HdrContentEncoding = True + HdrContentEncoding == _ = False + _ == HdrContentEncoding = False + HdrContentLanguage == HdrContentLanguage = True + HdrContentLanguage == _ = False + _ == HdrContentLanguage = False + HdrContentLength == HdrContentLength = True + HdrContentLength == _ = False + _ == HdrContentLength = False + HdrContentLocation == HdrContentLocation = True + HdrContentLocation == _ = False + _ == HdrContentLocation = False + HdrContentMD5 == HdrContentMD5 = True + HdrContentMD5 == _ = False + _ == HdrContentMD5 = False + HdrContentRange == HdrContentRange = True + HdrContentRange == _ = False + _ == HdrContentRange = False + HdrContentType == HdrContentType = True + HdrContentType == _ = False + _ == HdrContentType = False + HdrETag == HdrETag = True + HdrETag == _ = False + _ == HdrETag = False + HdrExpires == HdrExpires = True + HdrExpires == _ = False + _ == HdrExpires = False + HdrLastModified == HdrLastModified = True + HdrLastModified == _ = False + _ == HdrLastModified = False + HdrContentTransferEncoding == HdrContentTransferEncoding = True + HdrContentTransferEncoding == _ = False + _ == HdrContentTransferEncoding = False -- | @headerMap@ is a straight assoc list for translating between header names -- and values. diff --git a/test/UnitTests.hs b/test/UnitTests.hs --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -1,6 +1,7 @@ module UnitTests ( unitTests ) where import Network.HTTP.Base +import Network.HTTP.Headers import Network.URI import Data.Maybe ( fromJust ) @@ -22,11 +23,47 @@ (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313})) (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo")))) +customHeaderNameComparison :: Assertion +customHeaderNameComparison = + assertEqual "custom header name" (HdrCustom "foo") (HdrCustom "Foo") + +customHeaderLookup :: Assertion +customHeaderLookup = + let val = "header value" + h = Header (HdrCustom "foo") val + + in assertEqual "custom header lookup" (Just val) + (lookupHeader (HdrCustom "Foo") [h]) + +caseInsensitiveHeaderParse :: Assertion +caseInsensitiveHeaderParse = + let expected = [ Header HdrContentType "blah" + , Header (HdrCustom "X-Unknown") "unused" + ] + input = [ "content-type: blah" + , "X-Unknown: unused" + ] + + match actual = + length actual == length expected && + and [ hdrName a == hdrName b && hdrValue a == hdrValue b + | (a, b) <- zip expected actual + ] + + in case parseHeaders input of + Left _ -> assertFailure "Failed header parse" + Right actual -> assert (match actual) + unitTests = [testGroup "Unit tests" [ testGroup "URI parsing" [ testCase "Parse IPv4 address" parseIPv4Address , testCase "Parse IPv6 address" parseIPv6Address ] + ] + , testGroup "Header tests" + [ testCase "Custom header name case-insensitive match" customHeaderNameComparison + , testCase "Custom header lookup" customHeaderLookup + , testCase "Case-insensitive parsing" caseInsensitiveHeaderParse ] ]