diff --git a/Network/HTTP/Types.hs b/Network/HTTP/Types.hs --- a/Network/HTTP/Types.hs +++ b/Network/HTTP/Types.hs @@ -169,6 +169,7 @@ , decodePathSegments , encodePathSegmentsRelative -- ** Path (segments + query string) +, extractPath , encodePath , decodePath -- ** URL encoding / decoding diff --git a/Network/HTTP/Types/Status.hs b/Network/HTTP/Types/Status.hs --- a/Network/HTTP/Types/Status.hs +++ b/Network/HTTP/Types/Status.hs @@ -73,6 +73,12 @@ , expectationFailed417 , status418 , imATeaPot418 +, status428 +, preconditionRequired428 +, status429 +, tooManyRequests429 +, status431 +, requestHeaderFieldsTooLarge431 , status500 , internalServerError500 , status501 @@ -84,6 +90,8 @@ , status504 , gatewayTimeout504 , status505 +, status511 +, networkAuthenticationRequired511 , httpVersionNotSupported505 , statusIsInformational , statusIsSuccessful @@ -96,12 +104,12 @@ import qualified Data.ByteString as B -- | HTTP Status. --- +-- -- Only the 'statusCode' is used for comparisons. --- +-- -- Please use 'mkStatus' to create status codes from code and message, or the 'Enum' instance or the -- status code constants (like 'ok200'). There might be additional record members in the future. --- +-- -- Note that the Show instance is only for debugging. data Status = Status { @@ -444,6 +452,36 @@ imATeaPot418 :: Status imATeaPot418 = status418 +-- | Precondition Required 428 +-- () +status428 :: Status +status428 = mkStatus 428 "Precondition Required" + +-- | Precondition Required 428 +-- () +preconditionRequired428 :: Status +preconditionRequired428 = status428 + +-- | Too Many Requests 429 +-- () +status429 :: Status +status429 = mkStatus 429 "Too Many Requests" + +-- | Too Many Requests 429 +-- () +tooManyRequests429 :: Status +tooManyRequests429 = status429 + +-- | Request Header Fields Too Large 431 +-- () +status431 :: Status +status431 = mkStatus 431 "Request Header Fields Too Large" + +-- | Request Header Fields Too Large 431 +-- () +requestHeaderFieldsTooLarge431 :: Status +requestHeaderFieldsTooLarge431 = status431 + -- | Internal Server Error 500 status500 :: Status status500 = mkStatus 500 "Internal Server Error" @@ -491,6 +529,16 @@ -- | HTTP Version Not Supported 505 httpVersionNotSupported505 :: Status httpVersionNotSupported505 = status505 + +-- | Network Authentication Required 511 +-- () +status511 :: Status +status511 = mkStatus 511 "Network Authentication Required" + +-- | Network Authentication Required 511 +-- () +networkAuthenticationRequired511 :: Status +networkAuthenticationRequired511 = status511 -- | Informational class statusIsInformational :: Status -> Bool diff --git a/Network/HTTP/Types/URI.hs b/Network/HTTP/Types/URI.hs --- a/Network/HTTP/Types/URI.hs +++ b/Network/HTTP/Types/URI.hs @@ -23,6 +23,7 @@ , decodePathSegments , encodePathSegmentsRelative -- * Path (segments + query string) +, extractPath , encodePath , decodePath -- * URL encoding / decoding @@ -283,6 +284,31 @@ decodePathSegment :: B.ByteString -> Text decodePathSegment = decodeUtf8With lenientDecode . urlDecode False + +-- | Extract whole path (path segments + query) from a +-- . +-- +-- >>> extractPath "/path" +-- "/path" +-- +-- >>> extractPath "http://example.com:8080/path" +-- "/path" +-- +-- >>> extractPath "http://example.com" +-- "/" +-- +-- >>> extractPath "" +-- "/" +extractPath :: B.ByteString -> B.ByteString +extractPath = ensureNonEmpty . extract + where + extract path + | "http://" `B.isPrefixOf` path = (snd . breakOnSlash . B.drop 7) path + | "https://" `B.isPrefixOf` path = (snd . breakOnSlash . B.drop 8) path + | otherwise = path + breakOnSlash = B.breakByte 47 + ensureNonEmpty "" = "/" + ensureNonEmpty p = p -- | Encode a whole path (path segments + query). encodePath :: [Text] -> Query -> Blaze.Builder diff --git a/http-types.cabal b/http-types.cabal --- a/http-types.cabal +++ b/http-types.cabal @@ -1,5 +1,5 @@ Name: http-types -Version: 0.8.4 +Version: 0.8.5 Synopsis: Generic HTTP types for Haskell (for both client and server code). Description: Generic HTTP types for Haskell (for both client and server code). Homepage: https://github.com/aristidb/http-types @@ -37,11 +37,24 @@ case-insensitive >=0.2 && <1.3, blaze-builder >= 0.2.1.4 && < 0.4, text >= 0.11.0.2 - -- Other-modules: - -- Build-tools: -Test-suite runtests - main-is: runtests.hs - hs-source-dirs: test - type: exitcode-stdio-1.0 - build-depends: base, http-types, text, bytestring, blaze-builder, QuickCheck, hspec >= 1.3 +Test-suite spec + main-is: Spec.hs + hs-source-dirs: test + type: exitcode-stdio-1.0 + GHC-Options: -Wall + build-depends: base, + http-types, + text, + bytestring, + blaze-builder, + QuickCheck, + quickcheck-instances, + hspec >= 1.3 + +Test-Suite doctests + main-is: doctests.hs + hs-source-dirs: test + type: exitcode-stdio-1.0 + ghc-options: -threaded -Wall + build-depends: base, doctest >= 0.9.3 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ + "-idist/build/autogen/" + , "-optP-include" + , "-optPdist/build/autogen/cabal_macros.h" + , "-XOverloadedStrings" + , "Network/HTTP/Types.hs" + ] diff --git a/test/runtests.hs b/test/runtests.hs deleted file mode 100644 --- a/test/runtests.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -import Data.Text (Text) -import Debug.Trace -import Network.HTTP.Types -import Test.Hspec -import Test.QuickCheck -import qualified Blaze.ByteString.Builder as Blaze -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.Text as T - -main :: IO () -main = hspec $ do - describe "encode/decode path" $ do - it "is identity to encode and then decode" $ - property propEncodeDecodePath - it "does not escape period and dash" $ - Blaze.toByteString (encodePath ["foo-bar.baz"] []) `shouldBe` "/foo-bar.baz" - - describe "encode/decode query" $ do - it "is identity to encode and then decode" $ - property propEncodeDecodeQuery - it "add ? in front of Query if and only if necessary" $ - property propQueryQuestionMark - - describe "encode/decode path segments" $ do - it "is identity to encode and then decode" $ - property propEncodeDecodePathSegments - - describe "encode ByteRanges" $ do - it "first 500 bytes" $ - renderByteRanges [ByteRangeFromTo 0 499] `shouldBe` "bytes=0-499" - it "second 500 bytes" $ - renderByteRanges [ByteRangeFromTo 500 999] `shouldBe` "bytes=500-999" - it "final 500 bytes" $ - renderByteRanges [ByteRangeSuffix 500] `shouldBe` "bytes=-500" - it "final 500 bytes (of 1000, absolute)" $ - renderByteRanges [ByteRangeFrom 9500] `shouldBe` "bytes=9500-" - it "first and last bytes only" $ - renderByteRanges [ByteRangeFromTo 0 0, ByteRangeSuffix 1] `shouldBe` "bytes=0-0,-1" - it "non-canonical second 500 bytes (1)" $ - renderByteRanges [ByteRangeFromTo 500 600, ByteRangeFromTo 601 999] `shouldBe` "bytes=500-600,601-999" - it "non-canonical second 500 bytes (2)" $ - renderByteRanges [ByteRangeFromTo 500 700, ByteRangeFromTo 601 999] `shouldBe` "bytes=500-700,601-999" - -propEncodeDecodePath :: ([Text], Query) -> Bool -propEncodeDecodePath (p', q') = - let x = Blaze.toByteString $ encodePath a b - y = decodePath x - z = y == (a, b) - in if z then z else traceShow (a, b, x, y) z - where - a = if p' == [""] then [] else p' - b = filter (\(x, _) -> not (S.null x)) q' - -propEncodeDecodeQuery :: Query -> Bool -propEncodeDecodeQuery q' = - q == parseQuery (renderQuery True q) - where - q = filter (\(x, _) -> not (S.null x)) q' - -propQueryQuestionMark :: (Bool, Query) -> Bool -propQueryQuestionMark (useQuestionMark, query) = actual == expected - where - actual = case S8.uncons $ renderQuery useQuestionMark query of - Nothing -> False - Just ('?', _) -> True - _ -> False - expected = case (useQuestionMark, null query) of - (False, _) -> False - (True, True) -> False - (True, False) -> True - -propEncodeDecodePathSegments :: [Text] -> Bool -propEncodeDecodePathSegments p' = - p == decodePathSegments (Blaze.toByteString $ encodePathSegments p) - where - p = if p' == [""] then [] else p' - -instance Arbitrary Text where - arbitrary = fmap T.pack arbitrary - -instance Arbitrary S.ByteString where - arbitrary = fmap S.pack arbitrary