http-interchange (empty) → 0.1.0.0
raw patch · 8 files changed
+459/−0 lines, 8 filesdep +aesondep +basedep +bytebuild
Dependencies added: aeson, base, bytebuild, byteslice, bytesmith, bytestring, filepath, http-interchange, pretty-show, primitive, tasty, tasty-golden, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- http-interchange.cabal +48/−0
- src/Http/Bodied.hs +10/−0
- src/Http/Header.hs +125/−0
- src/Http/Message/Request.hs +88/−0
- src/Http/Message/Response.hs +74/−0
- test/Main.hs +79/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for http-interchange++## 0.1.0.0 -- 2023-07-25++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Andrew Martin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrew Martin nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ http-interchange.cabal view
@@ -0,0 +1,48 @@+cabal-version: 3.0+name: http-interchange+version: 0.1.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.+copyright: 2023 Andrew Martin+category: Data+build-type: Simple+extra-doc-files: CHANGELOG.md++library+ ghc-options: -Wall -O2+ exposed-modules:+ Http.Message.Request+ Http.Message.Response+ Http.Bodied+ Http.Header+ build-depends:+ , base >=4.16.4.0 && <5+ , bytesmith >=0.3.10+ , byteslice >=0.2.11+ , primitive >=0.7.4+ , text >=2.0+ , bytebuild >=0.3.10+ hs-source-dirs: src+ default-language: GHC2021++test-suite test+ ghc-options: -Wall+ default-language: GHC2021+ 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+ , byteslice+ , filepath+ , bytestring >=0.11+ , primitive >=0.7.4+ , pretty-show >=1.10
+ src/Http/Bodied.hs view
@@ -0,0 +1,10 @@+module Http.Bodied+ ( Bodied(..)+ ) where++import Data.Bytes.Chunks (Chunks)++data Bodied a = Bodied+ { metadata :: !a+ , body :: !Chunks+ }
+ src/Http/Header.hs view
@@ -0,0 +1,125 @@+{-# language LambdaCase #-}++module Http.Header+ ( Header(..)+ , decodeMany+ , parser+ , parserSmallArray+ , builder+ , builderSmallArray+ ) where++import Control.Monad (when)+import Data.Bytes (Bytes)+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.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++-- | 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)++uninitializedHeader :: Header+{-# noinline uninitializedHeader #-}+uninitializedHeader = errorWithoutStackTrace "parserHeaders: uninitialized header"++-- | 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)+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 ()++-- | 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+ 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)+ 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}++unsafeBytesToText :: Bytes -> Text+{-# 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.copy (Utf8.fromText name)+ <>+ Builder.ascii2 ':' ' '+ <>+ Builder.copy (Utf8.fromText value)+ <>+ Builder.ascii2 '\r' '\n'++builderSmallArray :: SmallArray Header -> Builder+builderSmallArray = foldMap builder
+ src/Http/Message/Request.hs view
@@ -0,0 +1,88 @@+{-# 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 view
@@ -0,0 +1,74 @@+{-# 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
+ test/Main.hs view
@@ -0,0 +1,79 @@+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}++module Main+ ( main+ ) where++import Control.Monad (when)+import System.FilePath (takeBaseName, replaceExtension)+import Test.Tasty (defaultMain, TestTree, testGroup)+import Test.Tasty.Golden (goldenVsString, findByExtension)+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.ByteString.Lazy.Char8 as LBC8+import qualified Data.Bytes.Chunks as Chunks+import qualified Data.Bytes as Bytes+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++main :: IO ()+main = defaultMain =<< goldenTests++deriving stock instance Generic Header+deriving stock instance Generic Request.RequestLine+deriving stock instance Generic Request.Request++deriving anyclass instance FromJSON Header+deriving anyclass instance FromJSON Request.RequestLine+deriving anyclass instance FromJSON Request.Request++goldenTests :: IO TestTree+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"+ ]+ ]++-- 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+-- function will prevent that change from breaking all the tests here.+addTrailingNewline :: String -> String+addTrailingNewline [] = "\n"+addTrailingNewline [x] = case x of+ '\n' -> [x]+ _ -> [x,'\n']+addTrailingNewline (x : xs) = x : addTrailingNewline xs