More tests more better

.gitignore

@@ -6,3 +6,5 @@ dist-newstyle/*
 *_flymake.hs
 *.lock
 .stack-work/*
+test/golden/*.actual
+test/.golden/**/actual

CHANGELOG → CHANGELOG.md

@@ -3,6 +3,8 @@
 ## 0.12.5 [XXXX-XX-XX]
 
 * Export everything from `Network.HTTP.Types`
+* Added a bunch of regression, unit and property tests for stability.
+* Updated the `README.md`
 
 ## 0.12.4 [2023-11-29]
 

Network/HTTP/Types/QueryLike.hs

@@ -57,4 +57,4 @@ instance QueryValueLike L.ByteString where toQueryValue = Just . B.concat . L.to
 instance QueryValueLike T.Text where toQueryValue = Just . T.encodeUtf8
 instance QueryValueLike [Char] where toQueryValue = Just . T.encodeUtf8 . T.pack
 instance QueryValueLike a => QueryValueLike (Maybe a) where
-    toQueryValue = maybe Nothing toQueryValue
+    toQueryValue mVal = mVal >>= toQueryValue

Network/HTTP/Types/Status.hs

@@ -617,6 +617,9 @@ status417 = mkStatus 417 "Expectation Failed"
 expectationFailed417 :: Status
 expectationFailed417 = status417
 
+-- FIXME: RFC 7168 updates the message to "I'm a Teapot" (capital T)
+-- Should we update this?
+
 -- | I'm a teapot 418
 --
 -- @since 0.6.6

README.md

@@ -0,0 +1,21 @@
+![Build Status](https://github.com/Vlix/http-types/actions/workflows/ci.yml/badge.svg?branch=master)
+[![Hackage](https://img.shields.io/hackage/v/http-types.svg)](https://hackage.haskell.org/package/http-types)
+[![Stackage LTS](http://stackage.org/package/http-types/badge/lts)](http://stackage.org/lts/package/http-types)
+[![Stackage Nightly](http://stackage.org/package/http-types/badge/nightly)](http://stackage.org/nightly/package/http-types)
+[![BSD 3-Clause License](https://img.shields.io/badge/License-BSD_3--Clause-blue.svg)](./LICENSE)
+
+# Generic HTTP types for Haskell (for both client and server code).
+
+The goal of this library is to have one location for any library, package or project
+to base their general HTTP types on for better interoperability.
+
+### This library provides basic types for the following:
+
+* HTTP versions (e.g. `HTTP/1.1`)
+* HTTP methods (e.g. `GET`)
+* HTTP headers (e.g. `Content-Type`)
+* HTTP statusses (e.g. `404`)
+
+This library also contains some utility functions, e.g. related to URI handling,
+that are not necessarily restricted in use to HTTP, but the scope is restricted
+to things that are useful inside HTTP, i.e. no FTP URI parsing.

http-types.cabal

@@ -12,7 +12,11 @@ Maintainer:          [email protected]
 Copyright:           (C) 2011 Aristid Breitkreuz
 Category:            Network, Web
 Build-type:          Simple
-Extra-source-files:  README, CHANGELOG
+Extra-source-files:
+    README.md
+    CHANGELOG.md
+    test/.golden/urlEncode-path/golden
+    test/.golden/urlEncode-query/golden
 
 Source-repository this
   type: git
@@ -42,18 +46,25 @@ Library
 Test-suite spec
   main-is:             Spec.hs
   hs-source-dirs:      test
-  other-modules:       Network.HTTP.Types.URISpec
+  other-modules:       Network.HTTP.Types.HeaderSpec
+                       Network.HTTP.Types.MethodSpec
+                       Network.HTTP.Types.StatusSpec
+                       Network.HTTP.Types.URISpec
+                       Network.HTTP.Types.VersionSpec
   type:                exitcode-stdio-1.0
   GHC-Options:         -Wall
   default-language:    Haskell2010
   build-tool-depends:  hspec-discover:hspec-discover
   build-depends:       base,
-                       http-types,
-                       text,
                        bytestring,
+                       case-insensitive,
+                       filepath,
+                       hspec >= 1.3,
+                       hspec-golden,
+                       http-types,
                        QuickCheck,
                        quickcheck-instances,
-                       hspec >= 1.3
+                       text
 
 Test-Suite doctests
   main-is:             doctests.hs

test/.golden/urlEncode-path/golden

@@ -0,0 +1 @@
+%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20%21%22%23$%25&%27%28%29%2A+,-.%2F0123456789:%3B%3C=%3E%3F@ABCDEFGHIJKLMNOPQRSTUVWXYZ%5B%5C%5D%5E_%60abcdefghijklmnopqrstuvwxyz%7B%7C%7D~%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF

test/.golden/urlEncode-query/golden

@@ -0,0 +1 @@
+%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20%21%22%23%24%25%26%27%28%29%2A%2B%2C-.%2F0123456789%3A%3B%3C%3D%3E%3F%40ABCDEFGHIJKLMNOPQRSTUVWXYZ%5B%5C%5D%5E_%60abcdefghijklmnopqrstuvwxyz%7B%7C%7D~%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF

test/Network/HTTP/Types/HeaderSpec.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Network.HTTP.Types.HeaderSpec (main, spec) where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import Data.CaseInsensitive (original)
+import Data.Word (Word8)
+import Test.Hspec
+import Test.QuickCheck (Arbitrary (..), Gen, NonEmptyList (..), oneof, property)
+import Test.QuickCheck.Instances ()
+
+import Network.HTTP.Types
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+    describe "Regression tests" $ do
+        mapM_ headerCheck allHeaders
+
+    describe "byte ranges" $ do
+        it "is identity to render and parse ByteRanges" $
+            property $ \(NonEmpty brs) ->
+                Just brs == parseByteRanges (renderByteRanges brs)
+        it "is satisfiable with from-to of zero" $
+            parseByteRanges "bytes=0-0" `shouldBe` Just [ByteRangeFromTo 0 0]
+        it "is not satisfiable with suffix of zero" $
+            parseByteRanges "bytes=-0" `shouldBe` Nothing
+        it "is not satisfiable with 'from' lower than 'to'" $
+            property $ \w81 w82 ->
+                let w8toInt = fromIntegral :: Word8 -> Integer
+                    -- if both are 0 it's @not (start < end)@ so we add 1
+                    start = w8toInt w81 + end + 1
+                    end = w8toInt w82
+                    range = show start <> "-" <> show end
+                 in parseByteRanges ("bytes=" <> B8.pack range) `shouldBe` Nothing
+
+type HeaderTuple = (HeaderName, HeaderName)
+
+allHeaders :: [HeaderTuple]
+allHeaders =
+    [ (hAccept, "Accept")
+    , (hAcceptCharset, "Accept-Charset")
+    , (hAcceptEncoding, "Accept-Encoding")
+    , (hAcceptLanguage, "Accept-Language")
+    , (hAcceptRanges, "Accept-Ranges")
+    , (hAge, "Age")
+    , (hAllow, "Allow")
+    , (hAuthorization, "Authorization")
+    , (hCacheControl, "Cache-Control")
+    , (hConnection, "Connection")
+    , (hContentDisposition, "Content-Disposition")
+    , (hContentEncoding, "Content-Encoding")
+    , (hContentLanguage, "Content-Language")
+    , (hContentLength, "Content-Length")
+    , (hContentLocation, "Content-Location")
+    , (hContentMD5, "Content-MD5")
+    , (hContentRange, "Content-Range")
+    , (hContentType, "Content-Type")
+    , (hCookie, "Cookie")
+    , (hDate, "Date")
+    , (hETag, "ETag")
+    , (hExpect, "Expect")
+    , (hExpires, "Expires")
+    , (hFrom, "From")
+    , (hHost, "Host")
+    , (hIfMatch, "If-Match")
+    , (hIfModifiedSince, "If-Modified-Since")
+    , (hIfNoneMatch, "If-None-Match")
+    , (hIfRange, "If-Range")
+    , (hIfUnmodifiedSince, "If-Unmodified-Since")
+    , (hLastModified, "Last-Modified")
+    , (hLocation, "Location")
+    , (hMaxForwards, "Max-Forwards")
+    , (hMIMEVersion, "MIME-Version")
+    , (hOrigin, "Origin")
+    , (hPragma, "Pragma")
+    , (hPrefer, "Prefer")
+    , (hPreferenceApplied, "Preference-Applied")
+    , (hProxyAuthenticate, "Proxy-Authenticate")
+    , (hProxyAuthorization, "Proxy-Authorization")
+    , (hRange, "Range")
+    , (hReferer, "Referer")
+    , (hRetryAfter, "Retry-After")
+    , (hServer, "Server")
+    , (hSetCookie, "Set-Cookie")
+    , (hTE, "TE")
+    , (hTrailer, "Trailer")
+    , (hTransferEncoding, "Transfer-Encoding")
+    , (hUpgrade, "Upgrade")
+    , (hUserAgent, "User-Agent")
+    , (hVary, "Vary")
+    , (hVia, "Via")
+    , (hWWWAuthenticate, "WWW-Authenticate")
+    , (hWarning, "Warning")
+    ]
+
+headerCheck :: HeaderTuple -> Spec
+headerCheck (hdr, msg) = do
+    it (B8.unpack . pad $ original msg) $ hdr `shouldBe` msg
+  where
+    pad bs =
+        let padding = B8.pack $ replicate (maxMsg - B.length bs) ' '
+         in bs <> padding
+
+maxMsg :: Int
+maxMsg = maximum $ fmap (B.length . original . snd) allHeaders
+
+-- | Generate valid ranges.
+--
+-- All values are positive and non-zero for easier testing.
+instance Arbitrary ByteRange where
+    arbitrary =
+        oneof
+            [ ByteRangeFrom <$> num
+            , num >>= \from ->
+                ByteRangeFromTo from . (from +) <$> num
+            , ByteRangeSuffix <$> num
+            ]
+      where
+        num =
+            (+ 1) -- making sure it's non-zero
+                . fromIntegral
+                <$> (arbitrary :: Gen Word) -- making sure it's positive

test/Network/HTTP/Types/MethodSpec.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Network.HTTP.Types.MethodSpec (main, spec) where
+
+import Test.Hspec
+import Test.QuickCheck (property)
+import Test.QuickCheck.Instances ()
+
+import Network.HTTP.Types
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+    describe "Regression tests" $ do
+        it "GET    " $ methodGet `shouldBe` "GET"
+        it "POST   " $ methodPost `shouldBe` "POST"
+        it "HEAD   " $ methodHead `shouldBe` "HEAD"
+        it "PUT    " $ methodPut `shouldBe` "PUT"
+        it "DELETE " $ methodDelete `shouldBe` "DELETE"
+        it "TRACE  " $ methodTrace `shouldBe` "TRACE"
+        it "CONNECT" $ methodConnect `shouldBe` "CONNECT"
+        it "OPTIONS" $ methodOptions `shouldBe` "OPTIONS"
+        it "PATCH  " $ methodPatch `shouldBe` "PATCH"
+        it "StdMethod has all constants" $
+            let methodList =
+                    [ methodGet
+                    , methodPost
+                    , methodHead
+                    , methodPut
+                    , methodDelete
+                    , methodTrace
+                    , methodConnect
+                    , methodOptions
+                    , methodPatch
+                    ]
+             in allMethods `shouldBe` methodList
+
+    describe "parse/render method" $ do
+        it "round trips" $ do
+            renderMethod . parseMethod <$> allMethods `shouldBe` allMethods
+        it "also round trips for any ByteString" $
+            property $ \bs ->
+                renderMethod (parseMethod bs) `shouldBe` bs
+
+allMethods :: [Method]
+allMethods =
+    renderStdMethod <$> [minBound @StdMethod .. maxBound]