packages feed

http-interchange 0.1.0.0 → 0.2.0.0

raw patch · 10 files changed

+346/−175 lines, 10 filesdep +contiguousdep ~base

Dependencies added: contiguous

Dependency ranges changed: base

Files

CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revision history for http-interchange +## 0.2.0.0 -- 2023-08-14++* Redo module structure+* Introduce Headers type. Currently a low performance implementation.+* Introduce Http.Types module, which reexports all types+ ## 0.1.0.0 -- 2023-07-25  * Initial release
http-interchange.cabal view
@@ -1,12 +1,15 @@ cabal-version: 3.0 name: http-interchange-version: 0.1.0.0+version: 0.2.0.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. Very minimal.+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@@ -15,10 +18,12 @@ library   ghc-options: -Wall -O2   exposed-modules:-    Http.Message.Request-    Http.Message.Response+    Http.Request+    Http.Response     Http.Bodied     Http.Header+    Http.Headers+    Http.Types   build-depends:     , base >=4.16.4.0 && <5     , bytesmith >=0.3.10@@ -26,6 +31,7 @@     , primitive >=0.7.4     , text >=2.0     , bytebuild >=0.3.10+    , contiguous >=0.6.4   hs-source-dirs: src   default-language: GHC2021
src/Http/Bodied.hs view
@@ -4,7 +4,10 @@  import Data.Bytes.Chunks (Chunks) +-- | An HTTP request or response with a body. data Bodied a = Bodied   { metadata :: !a+    -- ^ The request or response.   , body :: !Chunks+    -- ^ The body.   }
+ src/Http/Headers.hs view
@@ -0,0 +1,118 @@+{-# language DuplicateRecordFields #-}+{-# language DerivingStrategies #-}+{-# 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+-- things up.+module Http.Headers+  ( -- * Types+    Headers+  , LookupException(..)+    -- * Construct+  , fromArray+    -- * Expose+  , toArray+    -- * Lookup+  , lookup+  , lookupFirst+  , lookupAll+    -- * Specialized Lookup+  , lookupContentType+  , lookupContentLength+  , lookupTransferEncoding+  ) where++import Prelude hiding (lookup)++import Data.Text (Text)+import Data.Primitive (SmallArray)+import Http.Header (Header(Header))+import Data.Foldable (foldl')++import qualified Data.List as List+import qualified Data.Primitive.Contiguous as C+import qualified Data.Text as T+import qualified Http.Header++-- | 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)++-- | 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++-- | Convert array of headers to a 'Headers' collection that supports+-- efficient lookup.+fromArray :: SmallArray Header -> Headers+fromArray = 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.+lookupFirst ::+     Text -- header name+  -> Headers+  -> Maybe Header+lookupFirst needle (Headers 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 ::+     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+     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.+lookupAll ::+     Text -- header name+  -> Headers+  -> SmallArray Header+lookupAll needle (Headers 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++lookupTransferEncoding :: Headers -> Either LookupException Header+lookupTransferEncoding = lookup "transfer-encoding"++lookupContentType :: Headers -> Either LookupException Header+lookupContentType = lookup "content-type"++lookupContentLength :: Headers -> Either LookupException Header+lookupContentLength = lookup "content-length"
− src/Http/Message/Request.hs 
@@ -1,88 +0,0 @@-{-# language LambdaCase #-}-{-# language MagicHash #-}--module Http.Message.Request-  ( 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 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---- | The response status line and the response headers.-data Request = Request-  { requestLine :: !RequestLine-  , headers :: !(SmallArray Header)-  } deriving (Show)--data RequestLine = RequestLine-  { method :: {-# UNPACK #-} !Text-  , path :: {-# UNPACK #-} !Text-  , versionMajor :: !Word8-  , versionMinor :: !Word8-  } deriving (Show)--builderRequestLine :: RequestLine -> Builder-builderRequestLine RequestLine{method,path,versionMajor,versionMinor} =-  Builder.copy (Utf8.fromText method)-  <>-  Builder.ascii ' '-  <>-  Builder.copy (Utf8.fromText path)-  <>-  Builder.ascii6 ' ' 'H' 'T' 'T' 'P' '/'-  <>-  Builder.word8Dec versionMajor-  <>-  Builder.ascii '.'-  <>-  Builder.word8Dec versionMinor-  <>-  Builder.ascii2 '\r' '\n'--toChunks :: Request -> Chunks-toChunks = Builder.run 256 . builder--toChunksOnto :: Request -> Chunks -> Chunks-toChunksOnto r ch = Builder.runOnto 256 (builder r) ch--builder :: Request -> Builder-builder Request{requestLine,headers} =-  builderRequestLine requestLine-  <>-  Header.builderSmallArray headers-  <>-  Builder.ascii2 '\r' '\n'---- | 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-    ( builderRequestLine requestLine-      <>-      Header.builderSmallArray headers-      <>-      Builder.cstring (Ptr "Content-Length: "#)-      <>-      Builder.word64Dec (fromIntegral (Chunks.length body))-      <>-      Builder.ascii4 '\r' '\n' '\r' '\n'-    ) body
− src/Http/Message/Response.hs 
@@ -1,74 +0,0 @@-{-# language LambdaCase #-}--module Http.Message.Response-  ( 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.Text (Text)-import Http.Header (Header)--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---- | The response status line and the response headers.-data Response = Response-  { statusLine :: !StatusLine-  , headers :: !(SmallArray Header)-  } deriving (Show)--data StatusLine = StatusLine-  { versionMajor :: !Word8-  , versionMinor :: !Word8-  , statusCode :: !Word16-  , statusReason :: {-# UNPACK #-} !Text-  } deriving (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 :: Int -> Bytes -> Maybe Response-decode !n !b =-  Parser.parseBytesMaybe (parserResponse n <* Parser.endOfInput ()) b--parserResponse ::-     Int -- ^ Maximum number of headers-  -> Parser () s Response-parserResponse !n = do-  statusLine <- parserStatusLine-  headers <- Header.parserSmallArray n-  pure Response{statusLine,headers}---- Consumes the trailing CRLF-parserStatusLine :: Parser () s StatusLine-parserStatusLine = do-  Latin.char5 () 'H' 'T' 'T' 'P' '/'-  versionMajor <- Latin.decWord8 ()-  Latin.char () '.'-  versionMinor <- Latin.decWord8 ()-  Latin.char () ' '-  statusCode <- Latin.decWord16 ()-  when (statusCode >= 1000) (Parser.fail ())-  Latin.char () ' '-  -- RFC 7230: reason-phrase = *( HTAB / SP / VCHAR / obs-text )-  statusReason <- Parser.takeWhile $ \c ->-    (c >= 0x20 && c <= 0x7e)-    ||-    (c == 0x09)-  Latin.char2 () '\r' '\n'-  pure StatusLine{versionMajor,versionMinor,statusCode,statusReason=unsafeBytesToText statusReason}--unsafeBytesToText :: Bytes -> Text-{-# inline unsafeBytesToText #-}-unsafeBytesToText (Bytes (ByteArray arr) off len) =-  Text.Text (Data.Text.Array.ByteArray arr) off len
+ src/Http/Request.hs view
@@ -0,0 +1,96 @@+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}++module Http.Request+  ( 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 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++-- | The request line and the request headers.+data Request = Request+  { requestLine :: !RequestLine+  , headers :: !Headers+  } deriving (Show)++-- | An HTTP request line+data RequestLine = RequestLine+  { method :: {-# UNPACK #-} !Text+  , path :: {-# UNPACK #-} !Text+  , versionMajor :: !Word8+  , versionMinor :: !Word8+  } deriving (Show)++builderRequestLine :: RequestLine -> Builder+builderRequestLine RequestLine{method,path,versionMajor,versionMinor} =+  Builder.copy (Utf8.fromText method)+  <>+  Builder.ascii ' '+  <>+  Builder.copy (Utf8.fromText path)+  <>+  Builder.ascii6 ' ' 'H' 'T' 'T' 'P' '/'+  <>+  Builder.word8Dec versionMajor+  <>+  Builder.ascii '.'+  <>+  Builder.word8Dec versionMinor+  <>+  Builder.ascii2 '\r' '\n'++toChunks :: Request -> Chunks+toChunks = Builder.run 256 . builder++toChunksOnto :: Request -> Chunks -> Chunks+toChunksOnto r ch = Builder.runOnto 256 (builder r) ch++builder :: Request -> Builder+builder Request{requestLine,headers} =+  builderRequestLine requestLine+  <>+  Header.builderSmallArray headersArray+  <>+  Builder.ascii2 '\r' '\n'+  where+  headersArray = Headers.toArray headers++-- | 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+    ( builderRequestLine requestLine+      <>+      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
+ src/Http/Response.hs view
@@ -0,0 +1,78 @@+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}++module Http.Response+  ( 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.Text (Text)+import Http.Header (Header)+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++-- | The response status line and the response headers.+data Response = Response+  { statusLine :: !StatusLine+  , headers :: !Headers+  } deriving (Show)++data StatusLine = StatusLine+  { versionMajor :: !Word8+  , versionMinor :: !Word8+  , statusCode :: !Word16+  , statusReason :: {-# UNPACK #-} !Text+  } deriving (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 :: Int -> Bytes -> Maybe Response+decode !n !b =+  Parser.parseBytesMaybe (parserResponse n <* Parser.endOfInput ()) b++parserResponse ::+     Int -- ^ Maximum number of headers+  -> Parser () s Response+parserResponse !n = do+  statusLine <- parserStatusLine+  headers0 <- Header.parserSmallArray n+  let !headers = Headers.fromArray headers0+  pure Response{statusLine,headers}++-- Consumes the trailing CRLF+parserStatusLine :: Parser () s StatusLine+parserStatusLine = do+  Latin.char5 () 'H' 'T' 'T' 'P' '/'+  versionMajor <- Latin.decWord8 ()+  Latin.char () '.'+  versionMinor <- Latin.decWord8 ()+  Latin.char () ' '+  statusCode <- Latin.decWord16 ()+  when (statusCode >= 1000) (Parser.fail ())+  Latin.char () ' '+  -- RFC 7230: reason-phrase = *( HTAB / SP / VCHAR / obs-text )+  statusReason <- Parser.takeWhile $ \c ->+    (c >= 0x20 && c <= 0x7e)+    ||+    (c == 0x09)+  Latin.char2 () '\r' '\n'+  pure StatusLine{versionMajor,versionMinor,statusCode,statusReason=unsafeBytesToText statusReason}++unsafeBytesToText :: Bytes -> Text+{-# inline unsafeBytesToText #-}+unsafeBytesToText (Bytes (ByteArray arr) off len) =+  Text.Text (Data.Text.Array.ByteArray arr) off len
+ src/Http/Types.hs view
@@ -0,0 +1,22 @@+{-# language DuplicateRecordFields #-}++module Http.Types+  ( -- * Request+    Request(..)+  , RequestLine(..)+    -- * Response+  , Response(..)+  , StatusLine(..)+    -- * Header+  , Headers+  , Header(..)+  , LookupException(..)+    -- * 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(..))
test/Main.hs view
@@ -6,25 +6,26 @@   ) where  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 Text.Show.Pretty (ppShow)-import Http.Header (Header)-import Data.Aeson (FromJSON)-import GHC.Generics (Generic)-import Http.Message.Request (Request) +import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy.Char8 as LBC8-import qualified Data.Bytes.Chunks as Chunks 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.Message.Request as Request-import qualified Http.Message.Response as Response import qualified Http.Header-import qualified Data.Aeson as Aeson-import qualified Data.List as List+import qualified Http.Headers as Headers+import qualified Http.Request as Request+import qualified Http.Response as Response  main :: IO () main = defaultMain =<< goldenTests@@ -36,6 +37,9 @@ deriving anyclass instance FromJSON Header deriving anyclass instance FromJSON Request.RequestLine deriving anyclass instance FromJSON Request.Request++instance FromJSON Headers where+  parseJSON = fmap Headers.fromArray . Aeson.parseJSON  goldenTests :: IO TestTree goldenTests = do