http-interchange 0.3.1.0 → 0.3.2.0

raw patch · 9 files changed

+330/−298 lines, 9 filesdep ~basedep ~primitivePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, primitive

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• http-interchange.cabal +37/−34
• src/Http/Bodied.hs +5/−4
• src/Http/Header.hs +64/−68
• src/Http/Headers.hs +87/−63
• src/Http/Request.hs +40/−47
• src/Http/Response.hs +27/−26
• src/Http/Types.hs +16/−13
• test/Main.hs +50/−43

@@ -1,5 +1,9 @@ # Revision history for http-interchange +## 0.3.2.0 -- 2024-01-16++* Add `Eq` and `Show` to all data types.+ ## 0.3.1.0 -- 2023-08-16  * Add these to `Http.Headers`: cons, snoc, lookupHost, lookupAccept,

@@ -1,54 +1,57 @@-cabal-version: 3.0-name: http-interchange-version: 0.3.1.0-license: BSD-3-Clause-license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-synopsis: Types and serialization for HTTP+cabal-version:   3.0+name:            http-interchange+version:         0.3.2.0+license:         BSD-3-Clause+license-file:    LICENSE+author:          Andrew Martin+maintainer:      andrew.thaddeus@gmail.com+synopsis:        Types and serialization for HTTP description:   Types and serialization for HTTP. This includes things like request   line, status line, and headers. There is also a collection type   for headers that supports fast, case-insensitive lookup.-copyright: 2023 Andrew Martin-category: Data-build-type: Simple++copyright:       2023 Andrew Martin+category:        Data+build-type:      Simple extra-doc-files: CHANGELOG.md  library-  ghc-options: -Wall -O2+  ghc-options:      -Wall -O2   exposed-modules:-    Http.Request-    Http.Response     Http.Bodied     Http.Header     Http.Headers+    Http.Request+    Http.Response     Http.Types+   build-depends:-    , base >=4.16.3.0 && <5-    , bytesmith >=0.3.10-    , byteslice >=0.2.11-    , primitive >=0.7.4-    , text >=2.0-    , bytebuild >=0.3.10-    , contiguous >=0.6.3-  hs-source-dirs: src+    , base        >=4.16.3.0 && <5+    , bytebuild   >=0.3.10+    , byteslice   >=0.2.11+    , bytesmith   >=0.3.10+    , contiguous  >=0.6.3+    , primitive   >=0.9.0+    , text        >=2.0++  hs-source-dirs:   src   default-language: GHC2021  test-suite test-  ghc-options: -Wall+  ghc-options:      -Wall   default-language: GHC2021-  type: exitcode-stdio-1.0-  hs-source-dirs: test-  main-is: Main.hs+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Main.hs   build-depends:-    , aeson >=2.1-    , base >=4.16.4.0-    , http-interchange-    , tasty >=1.4.3-    , tasty-golden >=2.3.5+    , aeson             >=2.1+    , base              >=4.16.3.0     , byteslice+    , bytestring        >=0.11     , filepath-    , bytestring >=0.11-    , primitive >=0.7.4-    , pretty-show >=1.10+    , http-interchange+    , pretty-show       >=1.10+    , primitive         >=0.9.0+    , tasty             >=1.4.3+    , tasty-golden      >=2.3.5

@@ -1,5 +1,5 @@ module Http.Bodied-  ( Bodied(..)+  ( Bodied (..)   ) where  import Data.Bytes.Chunks (Chunks)@@ -7,7 +7,8 @@ -- | An HTTP request or response with a body. data Bodied a = Bodied   { metadata :: !a-    -- ^ The request or response.+  -- ^ The request or response.   , body :: !Chunks-    -- ^ The body.-  } deriving (Show,Eq)+  -- ^ The body.+  }+  deriving (Eq, Show)

@@ -1,7 +1,7 @@-{-# language LambdaCase #-}+{-# LANGUAGE LambdaCase #-}  module Http.Header-  ( Header(..)+  ( Header (..)   , decodeMany   , parser   , parserSmallArray@@ -9,117 +9,113 @@   , builderSmallArray   ) where -import Control.Monad (when) import Data.Bytes (Bytes)+import Data.Bytes.Builder (Builder) import Data.Bytes.Parser (Parser)-import Data.Bytes.Types (Bytes(Bytes))-import Data.Primitive (SmallArray,SmallMutableArray,ByteArray(ByteArray))-import Data.Word (Word8,Word16)+import Data.Bytes.Types (Bytes (Bytes))+import Data.Primitive (ByteArray (ByteArray), SmallArray, SmallMutableArray) import Data.Text (Text)-import Data.Bytes.Builder (Builder) -import qualified Data.Bytes as Bytes-import qualified Data.Bytes.Text.Utf8 as Utf8-import qualified Data.Bytes.Builder as Builder-import qualified Data.Text.Internal as Text-import qualified Data.Text.Array-import qualified Data.Bytes.Parser as Parser-import qualified Data.Bytes.Parser.Latin as Latin-import qualified Data.Primitive as PM+import Data.Bytes qualified as Bytes+import Data.Bytes.Builder qualified as Builder+import Data.Bytes.Parser qualified as Parser+import Data.Bytes.Parser.Latin qualified as Latin+import Data.Bytes.Text.Utf8 qualified as Utf8+import Data.Primitive qualified as PM+import Data.Text.Array qualified+import Data.Text.Internal qualified as Text --- | An HTTP header. This type does not enforce a restricted character--- set. If, for example, the user creates a header whose key has a colon--- character, the resulting request will be malformed.+{- | An HTTP header. This type does not enforce a restricted character+set. If, for example, the user creates a header whose key has a colon+character, the resulting request will be malformed.+-} data Header = Header   { name :: {-# UNPACK #-} !Text   , value :: {-# UNPACK #-} !Text-  } deriving (Show)+  }+  deriving (Eq, Show)  uninitializedHeader :: Header-{-# noinline uninitializedHeader #-}+{-# NOINLINE uninitializedHeader #-} uninitializedHeader = errorWithoutStackTrace "parserHeaders: uninitialized header" --- | Parse headers. Expects two CRLF sequences in a row at the end.--- Fails if leftovers are encountered.+{- | Parse headers. Expects two CRLF sequences in a row at the end.+Fails if leftovers are encountered.+-} decodeMany :: Int -> Bytes -> Maybe (SmallArray Header) decodeMany !n !b = Parser.parseBytesMaybe (parserSmallArray n <* Parser.endOfInput ()) b-  + -- Parse headers. Stops after encountering two CRLF sequences in -- a row. parserSmallArray ::-     Int -- maximum number of headers allowed, recommended 128-  -> Parser () s (SmallArray Header)+  Int -> -- maximum number of headers allowed, recommended 128+  Parser () s (SmallArray Header) parserSmallArray !n = do   dst <- Parser.effect (PM.newSmallArray n uninitializedHeader)   parserHeaderStep 0 n dst  parserHeaderStep ::-     Int -- index-  -> Int -- remaining length-  -> SmallMutableArray s Header-  -> Parser () s (SmallArray Header)-parserHeaderStep !ix !n !dst = Latin.trySatisfy (== '\r') >>= \case-  True -> do-    Latin.char () '\n'-    Parser.effect $ do-      PM.shrinkSmallMutableArray dst ix-      PM.unsafeFreezeSmallArray dst-  False -> if n > 0-    then do-      header <- parser-      Parser.effect (PM.writeSmallArray dst ix header)-      parserHeaderStep (ix + 1) (n - 1) dst-    else Parser.fail ()+  Int -> -- index+  Int -> -- remaining length+  SmallMutableArray s Header ->+  Parser () s (SmallArray Header)+parserHeaderStep !ix !n !dst =+  Latin.trySatisfy (== '\r') >>= \case+    True -> do+      Latin.char () '\n'+      Parser.effect $ do+        PM.shrinkSmallMutableArray dst ix+        PM.unsafeFreezeSmallArray dst+    False ->+      if n > 0+        then do+          header <- parser+          Parser.effect (PM.writeSmallArray dst ix header)+          parserHeaderStep (ix + 1) (n - 1) dst+        else Parser.fail () --- | Parse a single HTTP header including the trailing CRLF sequence.--- From RFC 7230:------ > header-field   = field-name ":" OWS field-value OWS--- > field-name     = token--- > field-value    = *( field-content / obs-fold )--- > field-content  = field-vchar [ 1*( SP / HTAB ) field-vchar ]--- > field-vchar    = VCHAR / obs-text+{- | Parse a single HTTP header including the trailing CRLF sequence.+From RFC 7230:++> header-field   = field-name ":" OWS field-value OWS+> field-name     = token+> field-value    = *( field-content / obs-fold )+> field-content  = field-vchar [ 1*( SP / HTAB ) field-vchar ]+> field-vchar    = VCHAR / obs-text+-} parser :: Parser () s Header parser = do   -- Header name may contain: a-z, A-Z, 0-9, underscore, hyphen   !name <- Parser.takeWhile $ \c ->     (c >= 0x41 && c <= 0x5A)-    ||-    (c >= 0x61 && c <= 0x7A)-    ||-    (c >= 0x30 && c <= 0x39)-    ||-    c == 0x2D-    ||-    c == 0x5F+      || (c >= 0x61 && c <= 0x7A)+      || (c >= 0x30 && c <= 0x39)+      || c == 0x2D+      || c == 0x5F   Latin.char () ':'   Latin.skipWhile (\c -> c == ' ' || c == '\t')   -- Header name allows vchar, space, and tab.   value0 <- Parser.takeWhile $ \c ->     (c >= 0x20 && c <= 0x7e)-    ||-    (c == 0x09)+      || (c == 0x09)   Latin.char2 () '\r' '\n'   -- We only need to trim the end because the leading spaces and tab   -- were already skipped.   let !value = Bytes.dropWhileEnd (\c -> c == 0x20 || c == 0x09) value0-  pure Header{name=unsafeBytesToText name,value=unsafeBytesToText value}+  pure Header {name = unsafeBytesToText name, value = unsafeBytesToText value}  unsafeBytesToText :: Bytes -> Text-{-# inline unsafeBytesToText #-}+{-# INLINE unsafeBytesToText #-} unsafeBytesToText (Bytes (ByteArray arr) off len) =   Text.Text (Data.Text.Array.ByteArray arr) off len  -- | Encode a header. Includes the trailing CRLF sequence. builder :: Header -> Builder-builder Header{name,value} =+builder Header {name, value} =   Builder.copy (Utf8.fromText name)-  <>-  Builder.ascii2 ':' ' '-  <>-  Builder.copy (Utf8.fromText value)-  <>-  Builder.ascii2 '\r' '\n'+    <> Builder.ascii2 ':' ' '+    <> Builder.copy (Utf8.fromText value)+    <> Builder.ascii2 '\r' '\n'  builderSmallArray :: SmallArray Header -> Builder builderSmallArray = foldMap builder

@@ -1,7 +1,7 @@-{-# language DuplicateRecordFields #-}-{-# language DerivingStrategies #-}-{-# language GeneralizedNewtypeDeriving #-}-{-# language OverloadedStrings #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}  -- TODO: Right now, this uses a crummy implementation. Instead, we -- should hash all the keys and search the hashes first to speed@@ -9,28 +9,36 @@ module Http.Headers   ( -- * Types     Headers-  , LookupException(..)+  , LookupException (..)+     -- * Construct   , fromArray   , fromList+     -- * Modify   , cons   , snoc+     -- * Expose   , toArray+     -- * Lookup   , lookup   , lookupFirst   , lookupAll+     -- * Specialized Lookup+  , lookupLocation   , lookupContentType   , lookupContentLength   , lookupTransferEncoding   , lookupHost   , lookupAccept   , lookupDate+     -- * Specialized Snoc   , snocContentLength+     -- * Specialized Absence   , lacksContentLengthAndTransferEncoding   ) where@@ -41,36 +49,40 @@ import Data.Maybe (isNothing) import Data.Primitive (SmallArray) import Data.Text (Text)-import Http.Header (Header(Header))+import Http.Header (Header (Header)) -import qualified Data.List as List-import qualified Data.Primitive as PM-import qualified Data.Primitive.Contiguous as C-import qualified Data.Text as T-import qualified GHC.Exts as Exts-import qualified Http.Header+import Data.List qualified as List+import Data.Primitive qualified as PM+import Data.Primitive.Contiguous qualified as C+import Data.Text qualified as T+import GHC.Exts qualified as Exts+import Http.Header qualified --- | Collection of HTTP headers. Supports case-insensitive lookup.--- This is intended to be used for small collections of headers.--- Expect degraded performance if this is used for collections of--- more than 128 headers.------ This preserves the original order of the headers and the original--- case of the header names.+{- | Collection of HTTP headers. Supports case-insensitive lookup.+This is intended to be used for small collections of headers.+Expect degraded performance if this is used for collections of+more than 128 headers.++This preserves the original order of the headers and the original+case of the header names.+-} newtype Headers = Headers (SmallArray Header)-  deriving newtype (Show,Semigroup,Monoid)+  deriving newtype (Eq, Show, Semigroup, Monoid) --- | Many headers cannot appear more than once. This is part of--- the return type for 'lookup', and it helps us track whether the--- lookup failure was the result of something that might be expected--- (the header was @Missing@) or something that is definitely a mistake--- (the header was duplicated).+{- | Many headers cannot appear more than once. This is part of+the return type for 'lookup', and it helps us track whether the+lookup failure was the result of something that might be expected+(the header was @Missing@) or something that is definitely a mistake+(the header was duplicated).+-} data LookupException   = Duplicate   | Missing+  deriving (Eq, Show) --- | Convert array of headers to a 'Headers' collection that supports--- efficient lookup.+{- | Convert array of headers to a 'Headers' collection that supports+efficient lookup.+-} fromArray :: SmallArray Header -> Headers fromArray = Headers @@ -82,55 +94,64 @@ snoc :: Headers -> Header -> Headers snoc (Headers hdrs) hdr = Headers (C.insertAt hdrs (PM.sizeofSmallArray hdrs) hdr) --- | Convert list of headers to a 'Headers' collection that supports--- efficient lookup.+{- | Convert list of headers to a 'Headers' collection that supports+efficient lookup.+-} fromList :: [Header] -> Headers fromList = Headers . Exts.fromList --- | Recover the original headers from from the 'Headers' collection.--- This is @O(1)@ and is most commonly used to fold over the headers.+{- | Recover the original headers from from the 'Headers' collection.+This is @O(1)@ and is most commonly used to fold over the headers.+-} toArray :: Headers -> SmallArray Header toArray (Headers xs) = xs --- | Case insensitive lookup of an HTTP header. If the header is present,--- returns both the original header name (may differs in case from the--- header name searched for) and the header value. Only returns the first--- occurrence of the header.+{- | Case insensitive lookup of an HTTP header. If the header is present,+returns both the original header name (may differs in case from the+header name searched for) and the header value. Only returns the first+occurrence of the header.+-} lookupFirst ::-     Text -- header name-  -> Headers-  -> Maybe Header+  Text -> -- header name+  Headers ->+  Maybe Header lookupFirst needle (Headers hdrs) =-  List.find (\Header{name} -> caseInsensitiveEq needle name) hdrs+  List.find (\Header {name} -> caseInsensitiveEq needle name) hdrs --- | Lookup a header that should not appear more than one time and verify--- that it did not occur more than once. If it appears more than once--- (or less than once), returns a 'LookupException'.+{- | Lookup a header that should not appear more than one time and verify+that it did not occur more than once. If it appears more than once+(or less than once), returns a 'LookupException'.+-} lookup ::-     Text -- header name-  -> Headers-  -> Either LookupException Header+  Text -> -- header name+  Headers ->+  Either LookupException Header lookup needle hdrs@(Headers xs) = case lookupFirst needle hdrs of   Nothing -> Left Missing   Just hdr ->-    let count = foldl'-          (\acc Header{name} -> if caseInsensitiveEq needle name-            then acc + 1-            else acc-          ) (0 :: Int) xs+    let count =+          foldl'+            ( \acc Header {name} ->+                if caseInsensitiveEq needle name+                  then acc + 1+                  else acc+            )+            (0 :: Int)+            xs      in if count > 1 then Left Duplicate else Right hdr --- | Lookup a header that may appear more than once. Some headers--- (e.g. @Set-Cookie@, @X-Forwarded-For@) are allowed to appear multiple--- times. This returns all the headers that matched along with their--- original names.+{- | Lookup a header that may appear more than once. Some headers+(e.g. @Set-Cookie@, @X-Forwarded-For@) are allowed to appear multiple+times. This returns all the headers that matched along with their+original names.+-} lookupAll ::-     Text -- header name-  -> Headers-  -> SmallArray Header+  Text -> -- header name+  Headers ->+  SmallArray Header lookupAll needle (Headers hdrs) =-  C.filter (\Header{name} -> caseInsensitiveEq needle name) hdrs-  +  C.filter (\Header {name} -> caseInsensitiveEq needle name) hdrs+ -- TODO: Make this not allocate caseInsensitiveEq :: Text -> Text -> Bool caseInsensitiveEq a b = T.toLower a == T.toLower b@@ -153,13 +174,16 @@ lookupDate :: Headers -> Either LookupException Header lookupDate = lookup "date" +lookupLocation :: Headers -> Either LookupException Header+lookupLocation = lookup "location"+ snocContentLength :: Headers -> Text -> Headers snocContentLength hdrs val = snoc hdrs (Header "Content-Length" val) --- | Returns @True@ if both the @Content-Length@ and @Transfer-Encoding@--- headers are missing.+{- | Returns @True@ if both the @Content-Length@ and @Transfer-Encoding@+headers are missing.+-} lacksContentLengthAndTransferEncoding :: Headers -> Bool lacksContentLengthAndTransferEncoding hdrs =   isNothing (lookupFirst "content-length" hdrs)-  &&-  isNothing (lookupFirst "transfer-encoding" hdrs)+    && isNothing (lookupFirst "transfer-encoding" hdrs)

@@ -1,88 +1,81 @@-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MagicHash #-}  module Http.Request-  ( Request(..)-  , RequestLine(..)+  ( Request (..)+  , RequestLine (..)+     -- * Encode Request   , builder   , toChunks   , toChunksOnto+     -- * Encode Request with Body   , bodiedToChunks   ) where  import Data.Bytes.Builder (Builder) import Data.Bytes.Chunks (Chunks)-import Data.Primitive (SmallArray) import Data.Text (Text)-import Data.Word (Word8)-import GHC.Exts (Ptr(Ptr))-import Http.Bodied (Bodied(..))-import Http.Header (Header)+import GHC.Exts (Ptr (Ptr))+import Http.Bodied (Bodied (..)) import Http.Headers (Headers) -import qualified Data.Bytes.Text.Utf8 as Utf8-import qualified Data.Bytes.Builder as Builder-import qualified Data.Bytes.Chunks as Chunks-import qualified Http.Header as Header-import qualified Http.Headers as Headers+import Data.Bytes.Builder qualified as Builder+import Data.Bytes.Chunks qualified as Chunks+import Data.Bytes.Text.Utf8 qualified as Utf8+import Http.Header qualified as Header+import Http.Headers qualified as Headers  -- | The request line and the request headers. data Request = Request   { requestLine :: !RequestLine   , headers :: !Headers-  } deriving (Show)+  }+  deriving (Eq, Show)  -- | An HTTP request line data RequestLine = RequestLine   { method :: {-# UNPACK #-} !Text   , path :: {-# UNPACK #-} !Text-  } deriving (Show)+  }+  deriving (Eq, Show)  builderRequestLine :: RequestLine -> Builder-builderRequestLine RequestLine{method,path} =+builderRequestLine RequestLine {method, path} =   Builder.copy (Utf8.fromText method)-  <>-  Builder.ascii ' '-  <>-  Builder.copy (Utf8.fromText path)-  <>-  Builder.ascii6 ' ' 'H' 'T' 'T' 'P' '/'-  <>-  Builder.ascii5 '1' '.' '1' '\r' '\n'+    <> Builder.ascii ' '+    <> Builder.copy (Utf8.fromText path)+    <> Builder.ascii6 ' ' 'H' 'T' 'T' 'P' '/'+    <> Builder.ascii5 '1' '.' '1' '\r' '\n'  toChunks :: Request -> Chunks toChunks = Builder.run 256 . builder  toChunksOnto :: Request -> Chunks -> Chunks-toChunksOnto r ch = Builder.runOnto 256 (builder r) ch+toChunksOnto r = Builder.runOnto 256 (builder r)  builder :: Request -> Builder-builder Request{requestLine,headers} =+builder Request {requestLine, headers} =   builderRequestLine requestLine-  <>-  Header.builderSmallArray headersArray-  <>-  Builder.ascii2 '\r' '\n'-  where+    <> Header.builderSmallArray headersArray+    <> Builder.ascii2 '\r' '\n'+ where   headersArray = Headers.toArray headers --- | This adds the Content-Length header. It must not already--- be present.+{- | This adds the Content-Length header. It must not already+be present.+-} bodiedToChunks :: Bodied Request -> Chunks-bodiedToChunks Bodied{metadata=Request{requestLine,headers},body} =-  Builder.runOnto 256+bodiedToChunks Bodied {metadata = Request {requestLine, headers}, body} =+  Builder.runOnto+    256     ( builderRequestLine requestLine-      <>-      Header.builderSmallArray headersArray-      <>-      Builder.cstring (Ptr "Content-Length: "#)-      <>-      Builder.word64Dec (fromIntegral (Chunks.length body))-      <>-      Builder.ascii4 '\r' '\n' '\r' '\n'-    ) body-  where+        <> Header.builderSmallArray headersArray+        <> Builder.cstring (Ptr "Content-Length: "#)+        <> Builder.word64Dec (fromIntegral (Chunks.length body))+        <> Builder.ascii4 '\r' '\n' '\r' '\n'+    )+    body+ where   headersArray = Headers.toArray headers

@@ -1,55 +1,57 @@-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}+{-# LANGUAGE DuplicateRecordFields #-}  module Http.Response-  ( Response(..)-  , StatusLine(..)+  ( Response (..)+  , StatusLine (..)   , decode   ) where  import Control.Monad (when) import Data.Bytes (Bytes) import Data.Bytes.Parser (Parser)-import Data.Bytes.Types (Bytes(Bytes))-import Data.Primitive (SmallArray,ByteArray(ByteArray))-import Data.Word (Word8,Word16)+import Data.Bytes.Types (Bytes (Bytes))+import Data.Primitive (ByteArray (ByteArray)) import Data.Text (Text)-import Http.Header (Header)+import Data.Word (Word16) import Http.Headers (Headers) -import qualified Data.Text.Internal as Text-import qualified Data.Text.Array-import qualified Data.Bytes.Parser as Parser-import qualified Data.Bytes.Parser.Latin as Latin-import qualified Http.Header as Header-import qualified Http.Headers as Headers+import Data.Bytes.Parser qualified as Parser+import Data.Bytes.Parser.Latin qualified as Latin+import Data.Text.Array qualified+import Data.Text.Internal qualified as Text+import Http.Header qualified as Header+import Http.Headers qualified as Headers  -- | The response status line and the response headers. data Response = Response   { statusLine :: !StatusLine   , headers :: !Headers-  } deriving (Show)+  }+  deriving (Eq, Show)  data StatusLine = StatusLine   { statusCode :: !Word16   , statusReason :: {-# UNPACK #-} !Text-  } deriving (Show)+  }+  deriving (Eq, Show) --- | Decode the response status line and the response headers. Fails if--- any extraneous input is present after the double CRLF sequence that--- ends the headers.+{- | Decode the response status line and the response headers. Fails if+any extraneous input is present after the double CRLF sequence that+ends the headers.+-} decode :: Int -> Bytes -> Maybe Response decode !n !b =   Parser.parseBytesMaybe (parserResponse n <* Parser.endOfInput ()) b  parserResponse ::-     Int -- ^ Maximum number of headers-  -> Parser () s Response+  -- | Maximum number of headers+  Int ->+  Parser () s Response parserResponse !n = do   statusLine <- parserStatusLine   headers0 <- Header.parserSmallArray n   let !headers = Headers.fromArray headers0-  pure Response{statusLine,headers}+  pure Response {statusLine, headers}  -- Consumes the trailing CRLF parserStatusLine :: Parser () s StatusLine@@ -67,12 +69,11 @@   -- RFC 7230: reason-phrase = *( HTAB / SP / VCHAR / obs-text )   statusReason <- Parser.takeWhile $ \c ->     (c >= 0x20 && c <= 0x7e)-    ||-    (c == 0x09)+      || (c == 0x09)   Latin.char2 () '\r' '\n'-  pure StatusLine{statusCode,statusReason=unsafeBytesToText statusReason}+  pure StatusLine {statusCode, statusReason = unsafeBytesToText statusReason}  unsafeBytesToText :: Bytes -> Text-{-# inline unsafeBytesToText #-}+{-# INLINE unsafeBytesToText #-} unsafeBytesToText (Bytes (ByteArray arr) off len) =   Text.Text (Data.Text.Array.ByteArray arr) off len

@@ -1,22 +1,25 @@-{-# language DuplicateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields #-}  module Http.Types   ( -- * Request-    Request(..)-  , RequestLine(..)+    Request (..)+  , RequestLine (..)+     -- * Response-  , Response(..)-  , StatusLine(..)+  , Response (..)+  , StatusLine (..)+     -- * Header   , Headers-  , Header(..)-  , LookupException(..)+  , Header (..)+  , LookupException (..)+     -- * Bodied-  , Bodied(..)+  , Bodied (..)   ) where -import Http.Request (Request(..),RequestLine(..))-import Http.Response (Response(..),StatusLine(..))-import Http.Header (Header(..))-import Http.Headers (Headers,LookupException(..))-import Http.Bodied (Bodied(..))+import Http.Bodied (Bodied (..))+import Http.Header (Header (..))+import Http.Headers (Headers, LookupException (..))+import Http.Request (Request (..), RequestLine (..))+import Http.Response (Response (..), StatusLine (..))

@@ -1,5 +1,6 @@-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# OPTIONS_GHC -Wno-orphans #-}  module Main   ( main@@ -8,24 +9,24 @@ import Control.Monad (when) import Data.Aeson (FromJSON) import GHC.Generics (Generic)-import Http.Types (Request,Header)-import System.FilePath (takeBaseName, replaceExtension)-import Test.Tasty (defaultMain, TestTree, testGroup)-import Test.Tasty.Golden (goldenVsString, findByExtension) import Http.Headers (Headers)+import Http.Types (Header, Request)+import System.FilePath (replaceExtension, takeBaseName)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.Golden (findByExtension, goldenVsString) import Text.Show.Pretty (ppShow) -import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy.Char8 as LBC8-import qualified Data.Bytes as Bytes-import qualified Data.Bytes.Chunks as Chunks-import qualified Data.List as List-import qualified Data.Primitive as PM-import qualified GHC.Exts as Exts-import qualified Http.Header-import qualified Http.Headers as Headers-import qualified Http.Request as Request-import qualified Http.Response as Response+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy.Char8 qualified as LBC8+import Data.Bytes qualified as Bytes+import Data.Bytes.Chunks qualified as Chunks+import Data.List qualified as List+import Data.Primitive qualified as PM+import GHC.Exts qualified as Exts+import Http.Header qualified+import Http.Headers qualified as Headers+import Http.Request qualified as Request+import Http.Response qualified as Response  main :: IO () main = defaultMain =<< goldenTests@@ -45,32 +46,38 @@ goldenTests = do   responseFiles <- List.sort <$> findByExtension [".input"] "golden/response"   requestFiles <- List.sort <$> findByExtension [".json"] "golden/request"-  return $ testGroup "http"-    [ testGroup "response"-      [ goldenVsString-          (takeBaseName file) -- test name-          outFile -- golden file path-          (do contents <- Bytes.readFile file-              when (PM.sizeofPrimArray (Bytes.findIndices (Exts.fromList [0x0d,0x0a]) contents) < 2) $ do-                fail "Expected at least 2 CRLF sequences. Possible fix: unix2dos."-              case Response.decode 128 contents of-                Nothing -> fail "Could not decode HTTP response prelude"-                Just resp -> pure (LBC8.pack (addTrailingNewline (ppShow resp)))-          )-      | file <- responseFiles-      , let outFile = replaceExtension file ".output"-      ]-    , testGroup "request"-      [ goldenVsString-          (takeBaseName file) -- test name-          outFile -- golden file path-          (do req :: Request <- either fail pure =<< Aeson.eitherDecodeFileStrict' file-              pure $ LBC8.fromStrict $ Bytes.toByteString $ Chunks.concat $ Request.toChunks req-          )-      | file <- requestFiles-      , let outFile = replaceExtension file ".output"+  return $+    testGroup+      "http"+      [ testGroup+          "response"+          [ goldenVsString+            (takeBaseName file) -- test name+            outFile -- golden file path+            ( do+                contents <- Bytes.readFile file+                when (PM.sizeofPrimArray (Bytes.findIndices (Exts.fromList [0x0d, 0x0a]) contents) < 2) $ do+                  fail "Expected at least 2 CRLF sequences. Possible fix: unix2dos."+                case Response.decode 128 contents of+                  Nothing -> fail "Could not decode HTTP response prelude"+                  Just resp -> pure (LBC8.pack (addTrailingNewline (ppShow resp)))+            )+          | file <- responseFiles+          , let outFile = replaceExtension file ".output"+          ]+      , testGroup+          "request"+          [ goldenVsString+            (takeBaseName file) -- test name+            outFile -- golden file path+            ( do+                req :: Request <- either fail pure =<< Aeson.eitherDecodeFileStrict' file+                pure $ LBC8.fromStrict $ Bytes.toByteString $ Chunks.concat $ Request.toChunks req+            )+          | file <- requestFiles+          , let outFile = replaceExtension file ".output"+          ]       ]-    ]  -- If the trailing newline is missing, add it. The pretty-show library -- has a defect of omitting it, but if prett-show ever changes, this@@ -79,5 +86,5 @@ addTrailingNewline [] = "\n" addTrailingNewline [x] = case x of   '\n' -> [x]-  _ -> [x,'\n']+  _ -> [x, '\n'] addTrailingNewline (x : xs) = x : addTrailingNewline xs