packages feed

http-core (empty) → 0.1.0.0

raw patch · 10 files changed

+952/−0 lines, 10 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, hedgehog, http-core, http-types, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for http-core++## 0.1.0.0 -- 2026-04-27++* Initial release. Shared HTTP method and status code primitives used across+  the acolyte and spire package families.
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2024-2026, Josh Burgess++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+   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 HOLDER 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-core.cabal view
@@ -0,0 +1,94 @@+cabal-version:   3.0+name:            http-core+version:         0.1.0.0+synopsis:        Backend-agnostic HTTP request and response types+category:        Network.HTTP+description:+  Shared HTTP vocabulary types that are independent of any specific+  server backend (warp, snap, etc.) or middleware framework.+  .+  This is the Haskell equivalent of Rust's @http@ crate: a tiny,+  stable package defining Request and Response types that everyone+  depends on. WAI, warp, and other backends are confined to adapter+  packages; this package knows nothing about them.++license:         BSD-3-Clause+license-file:    LICENSE+author:          Josh Burgess+maintainer:      Josh Burgess <joshburgess.webdev@gmail.com>+homepage:        https://github.com/joshburgess/acolyte+bug-reports:     https://github.com/joshburgess/acolyte/issues+build-type:      Simple++extra-doc-files:+  CHANGELOG.md++library+  exposed-modules:+    Http.Core+    Http.Core.Request+    Http.Core.Response+    Http.Core.Extensions+    Http.Core.Body++  build-depends:+      base         >= 4.20 && < 5+    , bytestring   >= 0.11 && < 0.13+    , text         >= 2.0  && < 2.2+    , http-types   >= 0.12 && < 0.13+    , containers   >= 0.6  && < 0.8++  hs-source-dirs: src+  default-language: GHC2024+  default-extensions:+    AllowAmbiguousTypes+    OverloadedStrings+    StrictData++  -- -fno-full-laziness prevents GHC from floating IO actions out of+  -- lambdas in the streaming Body module. This transformation can+  -- silently introduce space leaks in pull-based streaming code.+  -- Applied to the whole library since it's small and no module+  -- benefits from full laziness floating.+  -- See: https://www.well-typed.com/blog/2016/09/sharing-conduit/+  ghc-options: -Wall -funbox-strict-fields -fno-full-laziness++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  default-language: GHC2024+  default-extensions:+    StrictData++  ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K"++  build-depends:+      base         >= 4.20 && < 5+    , http-core+    , bytestring   >= 0.11 && < 0.13+    , text         >= 2.0  && < 2.2+    , http-types   >= 0.12 && < 0.13++test-suite properties+  type: exitcode-stdio-1.0+  main-is: Properties.hs+  hs-source-dirs: test+  default-language: GHC2024+  default-extensions:+    OverloadedStrings+    StrictData++  ghc-options: -Wall++  build-depends:+      base         >= 4.20 && < 5+    , http-core+    , hedgehog     >= 1.4  && < 1.8+    , bytestring   >= 0.11 && < 0.13+    , text         >= 2.0  && < 2.2+    , http-types   >= 0.12 && < 0.13++source-repository head+  type:     git+  location: https://github.com/joshburgess/acolyte.git
+ src/Http/Core.hs view
@@ -0,0 +1,66 @@+-- | @http-core@ — backend-agnostic HTTP types.+--+-- Shared vocabulary types for HTTP requests and responses, independent+-- of any server backend (warp, snap, etc.) or middleware framework.+--+-- Everything above the backend adapter layer uses these types.+-- WAI, warp, and other backends are confined to adapter packages.+module Http.Core+  ( -- * Request+    Request (..)+  , RequestParts (..)+  , splitRequest+  , defaultRequest++    -- * Response+  , Response (..)+  , ok+  , created+  , noContent+  , badRequest+  , unauthorized+  , forbidden+  , notFound+  , methodNotAllowed+  , unprocessable+  , serverError++    -- * Extensions+  , Extensions+  , emptyExtensions+  , newExtensions+  , insertExtension+  , lookupExtension+  , deleteExtension+  , hasExtension++    -- * Body (strict + streaming)+  , Body (..)+  , BodyChunk (..)+  , FileRange (..)+  , fromBytes+  , fromLazyBytes+  , fromBuilder+  , fromText+  , streamBody+  , streamFromList+  , fileBody+  , emptyBody+  , bodyToStrict+  , foldBodyChunks+  , isEmptyBody++    -- * Re-exports from http-types+  , module Network.HTTP.Types.Method+  , module Network.HTTP.Types.Status+  , module Network.HTTP.Types.Header+  ) where++import Http.Core.Request+import Http.Core.Response+import Http.Core.Extensions+import Http.Core.Body++import Network.HTTP.Types.Method (Method, methodGet, methodPost, methodPut, methodDelete, methodPatch, methodHead, methodOptions)+import Network.HTTP.Types.Status (Status, status200, status201, status204, status400, status401, status403, status404, status405, status422, status500, statusCode)+import Network.HTTP.Types.Header (RequestHeaders, ResponseHeaders, Header, HeaderName, hContentType, hAccept, hAuthorization)
+ src/Http/Core/Body.hs view
@@ -0,0 +1,176 @@+-- | HTTP body types: strict, streaming, file, and empty.+--+-- Direct-style sum type — no CPS callbacks like WAI. Composes+-- naturally with spire's @Service req -> IO resp@ model.+module Http.Core.Body+  ( -- * Body type+    Body (..)+  , FileRange (..)+    -- * Constructors+  , fromBytes+  , fromLazyBytes+  , fromBuilder+  , fromText+  , streamBody+  , streamFromList+  , fileBody+  , emptyBody+    -- * Consumption+  , bodyToStrict+  , foldBodyChunks+  , isEmptyBody+    -- * Chunk type+  , BodyChunk (..)+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Builder as Builder+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Data.Word (Word64)+import Data.IORef+++-- | A chunk produced by a streaming body.+data BodyChunk+  = Chunk !ByteString  -- ^ A piece of data+  | ChunkFlush         -- ^ Flush hint (send buffered data now)+  deriving (Show, Eq)+++-- | A byte range within a file (for Range requests).+data FileRange = FileRange+  { fileRangeOffset :: !Word64+  , fileRangeLength :: !Word64+  } deriving (Show, Eq)+++-- | An HTTP body.+--+-- Four strategies for producing bytes:+--+-- * 'BodyStrict' — already in memory. Best for small bodies (JSON, text).+-- * 'BodyStream' — pull-based IO producer. The consumer calls the action+--   repeatedly; it returns 'Just chunk' or 'Nothing' when done. Simpler+--   than WAI's push-based 'StreamingBody' and composes better with+--   middleware that buffers or transforms chunks.+-- * 'BodyFile' — served from disk. Enables sendfile(2) zero-copy.+-- * 'BodyEmpty' — no body (HEAD, 204, 304).+data Body+  = BodyStrict !ByteString+  | BodyStream (IO (Maybe BodyChunk))+  | BodyFile   !FilePath !(Maybe FileRange)+  | BodyEmpty+++-- ===================================================================+-- Constructors+-- ===================================================================++-- | Create a body from a strict 'ByteString'.+fromBytes :: ByteString -> Body+fromBytes = BodyStrict+{-# INLINE fromBytes #-}++-- | Create a body from a lazy 'ByteString', forcing it to strict bytes.+fromLazyBytes :: LBS.ByteString -> Body+fromLazyBytes = BodyStrict . LBS.toStrict+{-# INLINE fromLazyBytes #-}++-- | Create a body from a 'Builder', rendering it to strict bytes.+fromBuilder :: Builder.Builder -> Body+fromBuilder = BodyStrict . LBS.toStrict . Builder.toLazyByteString+{-# INLINE fromBuilder #-}++-- | Create a body from 'Text', UTF-8 encoding it to bytes.+fromText :: Text -> Body+fromText = BodyStrict . TE.encodeUtf8+{-# INLINE fromText #-}++-- | Create a streaming body from a pull-based IO action.+--+-- The action is called repeatedly by the consumer. Return 'Nothing'+-- to signal end-of-body.+--+-- @+-- ref <- newIORef ["a", "b", "c"]+-- let body = streamBody $ do+--       chunks <- readIORef ref+--       case chunks of+--         []   -> pure Nothing+--         c:cs -> writeIORef ref cs >> pure (Just (Chunk c))+-- @+streamBody :: IO (Maybe BodyChunk) -> Body+streamBody = BodyStream++-- | Create a streaming body from a list of byte chunks.+-- Convenient for tests and simple cases.+streamFromList :: [ByteString] -> IO Body+streamFromList chunks = do+  ref <- newIORef chunks+  pure $ BodyStream $ do+    cs <- readIORef ref+    case cs of+      []       -> pure Nothing+      (c:rest) -> do+        writeIORef ref rest+        pure (Just (Chunk c))++-- | Create a body served from a file on disk, with an optional byte range.+fileBody :: FilePath -> Maybe FileRange -> Body+fileBody = BodyFile++-- | An empty body (for HEAD responses, 204, 304, etc.).+emptyBody :: Body+emptyBody = BodyEmpty+++-- ===================================================================+-- Consumption+-- ===================================================================++-- | Collect the entire body as strict bytes.+bodyToStrict :: Body -> IO ByteString+bodyToStrict (BodyStrict bs)       = pure bs+bodyToStrict (BodyStream pull)     = BS.concat <$> collectChunks pull+bodyToStrict (BodyFile path mRange) = do+  bs <- BS.readFile path+  pure $ case mRange of+    Nothing -> bs+    Just (FileRange off len) ->+      BS.take (fromIntegral len) (BS.drop (fromIntegral off) bs)+bodyToStrict BodyEmpty = pure BS.empty++-- | Fold over body chunks. Works for all body variants.+foldBodyChunks :: (a -> ByteString -> IO a) -> a -> Body -> IO a+foldBodyChunks f z (BodyStrict bs) = f z bs+foldBodyChunks f z (BodyStream pull) = go z+  where+    go !acc = do+      mChunk <- pull+      case mChunk of+        Nothing           -> pure acc+        Just (Chunk bs)   -> f acc bs >>= go+        Just ChunkFlush   -> go acc+foldBodyChunks f z (BodyFile path _) = BS.readFile path >>= f z+foldBodyChunks _ z BodyEmpty = pure z++-- | Check if a body is empty.+isEmptyBody :: Body -> Bool+isEmptyBody BodyEmpty       = True+isEmptyBody (BodyStrict bs) = BS.null bs+isEmptyBody _               = False+++-- Internal+collectChunks :: IO (Maybe BodyChunk) -> IO [ByteString]+collectChunks pull = go []+  where+    go acc = do+      mChunk <- pull+      case mChunk of+        Nothing         -> pure (reverse acc)+        Just (Chunk bs) -> go (bs : acc)+        Just ChunkFlush -> go acc
+ src/Http/Core/Extensions.hs view
@@ -0,0 +1,83 @@+-- | Typed heterogeneous map for passing data between middleware and handlers.+--+-- 'Extensions' is keyed by 'TypeRep' — each type can have at most one value+-- stored. This is how middleware communicates with handlers: auth middleware+-- stores the authenticated user, tracing middleware stores the request ID,+-- and handlers extract what they need.+--+-- Uses 'Map TypeRep' internally for collision-free keying (O(log n) lookup,+-- negligible for the ~5-10 entries per request). Thread-safe via+-- 'atomicModifyIORef''.+module Http.Core.Extensions+  ( -- * Extensions type+    Extensions+    -- * Construction+  , emptyExtensions+  , newExtensions+    -- * Operations+  , insertExtension+  , lookupExtension+  , deleteExtension+  , hasExtension+  ) where++import Data.IORef+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Typeable (Typeable, TypeRep, typeRep, Proxy (..))+import Unsafe.Coerce (unsafeCoerce)+++-- | An opaque wrapper around a value of any type.+data Any = forall a. Any a++-- | A mutable, typed heterogeneous map.+--+-- Keyed by TypeRep — zero collision risk, O(log n) lookup.+-- Thread-safe mutations via 'atomicModifyIORef''.+newtype Extensions = Extensions (IORef (Map TypeRep Any))+++-- | Create an empty 'Extensions'.+emptyExtensions :: IO Extensions+emptyExtensions = Extensions <$> newIORef Map.empty+{-# INLINE emptyExtensions #-}+++-- | Alias for 'emptyExtensions'.+newExtensions :: IO Extensions+newExtensions = emptyExtensions+{-# INLINE newExtensions #-}+++-- | Insert a typed value. Overwrites any existing value of the same type.+insertExtension :: forall a. Typeable a => a -> Extensions -> IO ()+insertExtension val (Extensions ref) =+  atomicModifyIORef' ref (\m -> (Map.insert (typeRep (Proxy @a)) (Any val) m, ()))+{-# INLINE insertExtension #-}+++-- | Look up a typed value. Returns 'Nothing' if no value of that type+-- has been inserted.+lookupExtension :: forall a. Typeable a => Extensions -> IO (Maybe a)+lookupExtension (Extensions ref) = do+  m <- readIORef ref+  pure $ case Map.lookup (typeRep (Proxy @a)) m of+    Just (Any val) -> Just (unsafeCoerce val)+    Nothing        -> Nothing+{-# INLINE lookupExtension #-}+++-- | Remove a typed value. No-op if the type is not present.+deleteExtension :: forall a. Typeable a => Extensions -> IO ()+deleteExtension (Extensions ref) =+  atomicModifyIORef' ref (\m -> (Map.delete (typeRep (Proxy @a)) m, ()))+{-# INLINE deleteExtension #-}+++-- | Check whether a typed value is present.+hasExtension :: forall a. Typeable a => Extensions -> IO Bool+hasExtension (Extensions ref) = do+  m <- readIORef ref+  pure $ Map.member (typeRep (Proxy @a)) m+{-# INLINE hasExtension #-}
+ src/Http/Core/Request.hs view
@@ -0,0 +1,90 @@+-- | Backend-agnostic HTTP request types.+--+-- 'Request' is parameterized by body type, enabling both strict+-- (@ByteString@) and streaming request bodies. Backend adapters+-- (spire-wai, etc.) convert from their native request types to this.+module Http.Core.Request+  ( -- * Request type+    Request (..)+    -- * Request parts (for extractors)+  , RequestParts (..)+  , splitRequest+    -- * Convenience constructors+  , defaultRequest+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Text (Text)+import Network.HTTP.Types (Method, Query, RequestHeaders, methodGet)++import Http.Core.Extensions (Extensions, emptyExtensions)+++-- | An HTTP request, parameterized by body type.+--+-- The body type parameter enables both strict (@ByteString@) and+-- streaming bodies. For the default server path, the body is strict+-- bytes (collected by the backend before dispatch).+data Request body = Request+  { requestMethod     :: !Method+  , requestPathRaw    :: !ByteString+  , requestPath       :: ![Text]+  , requestQuery      :: !Query+  , requestHeaders    :: !RequestHeaders+  , requestBody       :: !body+  , requestExtensions :: !Extensions+  }+++-- | The non-body parts of a request, used by 'FromRequestParts' extractors.+--+-- Extractors that don't need the body (path captures, query params,+-- headers, state, auth) work on 'RequestParts'. This allows multiple+-- extractors to read from the same request without consuming the body.+--+-- The body is extracted separately by 'FromRequest' (at most once per+-- handler).+data RequestParts = RequestParts+  { rpMethod     :: !Method+  , rpPathRaw    :: !ByteString+  , rpPath       :: ![Text]+  , rpQuery      :: !Query+  , rpHeaders    :: !RequestHeaders+  , rpExtensions :: !Extensions+  }+++-- | Split a strict-body request into parts + body.+--+-- This is the boundary between the router (which has the full request)+-- and the extractor system (which separates parts from body).+splitRequest :: Request ByteString -> (RequestParts, ByteString)+splitRequest req =+  ( RequestParts+      { rpMethod     = requestMethod req+      , rpPathRaw    = requestPathRaw req+      , rpPath       = requestPath req+      , rpQuery      = requestQuery req+      , rpHeaders    = requestHeaders req+      , rpExtensions = requestExtensions req+      }+  , requestBody req+  )+++-- | A minimal default request for testing.+--+-- Method: GET, path: "/", empty query/headers/body.+defaultRequest :: IO (Request ByteString)+defaultRequest = do+  exts <- emptyExtensions+  pure Request+    { requestMethod     = methodGet+    , requestPathRaw    = "/"+    , requestPath       = []+    , requestQuery      = []+    , requestHeaders    = []+    , requestBody       = BS.empty+    , requestExtensions = exts+    }
+ src/Http/Core/Response.hs view
@@ -0,0 +1,82 @@+-- | Backend-agnostic HTTP response types.+--+-- 'Response' is parameterized by body type, enabling both strict+-- (@ByteString@) and streaming response bodies. Backend adapters+-- convert from this to their native response types.+module Http.Core.Response+  ( -- * Response type+    Response (..)+    -- * Convenience constructors+  , ok+  , created+  , noContent+  , badRequest+  , unauthorized+  , forbidden+  , notFound+  , methodNotAllowed+  , unprocessable+  , serverError+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Network.HTTP.Types+  ( Status, ResponseHeaders+  , status200, status201, status204+  , status400, status401, status403, status404, status405, status422+  , status500+  )+++-- | An HTTP response, parameterized by body type.+data Response body = Response+  { responseStatus  :: !Status+  , responseHeaders :: !ResponseHeaders+  , responseBody    :: !body+  }+++-- ===================================================================+-- Convenience constructors (strict ByteString bodies)+-- ===================================================================++-- | 200 OK with a body.+ok :: ResponseHeaders -> ByteString -> Response ByteString+ok hdrs body = Response status200 hdrs body++-- | 201 Created with a body.+created :: ResponseHeaders -> ByteString -> Response ByteString+created hdrs body = Response status201 hdrs body++-- | 204 No Content (empty body).+noContent :: Response ByteString+noContent = Response status204 [] BS.empty++-- | 400 Bad Request with a body.+badRequest :: ResponseHeaders -> ByteString -> Response ByteString+badRequest hdrs body = Response status400 hdrs body++-- | 401 Unauthorized with a body.+unauthorized :: ResponseHeaders -> ByteString -> Response ByteString+unauthorized hdrs body = Response status401 hdrs body++-- | 403 Forbidden with a body.+forbidden :: ResponseHeaders -> ByteString -> Response ByteString+forbidden hdrs body = Response status403 hdrs body++-- | 404 Not Found with a body.+notFound :: ResponseHeaders -> ByteString -> Response ByteString+notFound hdrs body = Response status404 hdrs body++-- | 405 Method Not Allowed (empty body).+methodNotAllowed :: Response ByteString+methodNotAllowed = Response status405 [] BS.empty++-- | 422 Unprocessable Entity with a body.+unprocessable :: ResponseHeaders -> ByteString -> Response ByteString+unprocessable hdrs body = Response status422 hdrs body++-- | 500 Internal Server Error with a body.+serverError :: ResponseHeaders -> ByteString -> Response ByteString+serverError hdrs body = Response status500 hdrs body
+ test/Main.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Http.Core+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+++-- ===================================================================+-- Test helpers+-- ===================================================================++assert :: String -> Bool -> IO ()+assert label True  = putStrLn $ "  OK: " ++ label+assert label False = error   $ "FAIL: " ++ label+++-- ===================================================================+-- 1. Extensions: typed heterogeneous map+-- ===================================================================++newtype UserId = UserId Int deriving (Eq, Show)+newtype UserName = UserName String deriving (Eq, Show)++testExtensions :: IO ()+testExtensions = do+  exts <- emptyExtensions++  -- Empty lookup returns Nothing+  r1 <- lookupExtension @UserId exts+  assert "empty lookup returns Nothing" (r1 == Nothing)++  -- Insert and lookup+  insertExtension (UserId 42) exts+  r2 <- lookupExtension @UserId exts+  assert "insert then lookup succeeds" (r2 == Just (UserId 42))++  -- Different type returns Nothing+  r3 <- lookupExtension @UserName exts+  assert "wrong type returns Nothing" (r3 == Nothing)++  -- Multiple types coexist+  insertExtension (UserName "alice") exts+  r4 <- lookupExtension @UserId exts+  r5 <- lookupExtension @UserName exts+  assert "multiple types: UserId still there" (r4 == Just (UserId 42))+  assert "multiple types: UserName found" (r5 == Just (UserName "alice"))++  -- Overwrite same type+  insertExtension (UserId 99) exts+  r6 <- lookupExtension @UserId exts+  assert "overwrite replaces value" (r6 == Just (UserId 99))++  -- hasExtension+  h1 <- hasExtension @UserId exts+  h2 <- hasExtension @Bool exts+  assert "hasExtension: present" h1+  assert "hasExtension: absent" (not h2)++  -- deleteExtension+  deleteExtension @UserId exts+  r7 <- lookupExtension @UserId exts+  assert "delete removes value" (r7 == Nothing)++  -- UserName still there after deleting UserId+  r8 <- lookupExtension @UserName exts+  assert "delete doesn't affect other types" (r8 == Just (UserName "alice"))+++-- ===================================================================+-- 2. Request construction and splitting+-- ===================================================================++testRequest :: IO ()+testRequest = do+  req <- defaultRequest+  assert "default method is GET" (requestMethod req == methodGet)+  assert "default path is empty" (requestPath req == [])+  assert "default body is empty" (requestBody req == BS.empty)++  -- splitRequest preserves fields+  let (parts, body) = splitRequest req+  assert "split: method preserved" (rpMethod parts == methodGet)+  assert "split: body extracted" (body == BS.empty)++  -- Custom request+  exts <- emptyExtensions+  let req2 = Request+        { requestMethod     = methodPost+        , requestPathRaw    = "/users/42"+        , requestPath       = ["users", "42"]+        , requestQuery      = [("format", Just "json")]+        , requestHeaders    = [("Content-Type", "application/json")]+        , requestBody       = "{\"name\":\"alice\"}" :: ByteString+        , requestExtensions = exts+        }+  let (parts2, body2) = splitRequest req2+  assert "custom: method is POST" (rpMethod parts2 == methodPost)+  assert "custom: path segments" (rpPath parts2 == ["users", "42"])+  assert "custom: body content" (body2 == "{\"name\":\"alice\"}")+++-- ===================================================================+-- 3. Response construction+-- ===================================================================++testResponse :: IO ()+testResponse = do+  let r1 = ok [("Content-Type", "text/plain")] "hello"+  assert "ok: status 200" (statusCode (responseStatus r1) == 200)+  assert "ok: body" (responseBody r1 == "hello")++  let r2 = notFound [] "not here"+  assert "notFound: status 404" (statusCode (responseStatus r2) == 404)++  assert "noContent: status 204" (statusCode (responseStatus noContent) == 204)+  assert "noContent: empty body" (responseBody noContent == BS.empty)++  let r3 = serverError [] "oops"+  assert "serverError: status 500" (statusCode (responseStatus r3) == 500)++  let r4 = created [("Location", "/users/1")] "{\"id\":1}"+  assert "created: status 201" (statusCode (responseStatus r4) == 201)++  assert "methodNotAllowed: status 405" (statusCode (responseStatus methodNotAllowed) == 405)++  let r5 = unprocessable [] "validation failed"+  assert "unprocessable: status 422" (statusCode (responseStatus r5) == 422)+++-- ===================================================================+-- Main+-- ===================================================================++main :: IO ()+main = do+  putStrLn "http-core tests:"+  putStrLn ""+  putStrLn "Extensions:"+  testExtensions+  putStrLn ""+  putStrLn "Request:"+  testRequest+  putStrLn ""+  putStrLn "Response:"+  testResponse+  putStrLn ""+  putStrLn "All http-core tests passed."
+ test/Properties.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main (main) where++import Http.Core+import Http.Core.Body+import Http.Core.Extensions (emptyExtensions, insertExtension, lookupExtension, deleteExtension)++import Data.Typeable (Typeable)+import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types (Query)++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+++-- ===================================================================+-- Test value types+-- ===================================================================++newtype TestVal = TestVal Int+  deriving (Show, Eq, Typeable)+++-- ===================================================================+-- Generators+-- ===================================================================++genInt :: Gen Int+genInt = Gen.int (Range.linearFrom 0 (-10000) 10000)++genByteString :: Gen ByteString+genByteString = Gen.bytes (Range.linear 0 256)++genText :: Gen Text+genText = Gen.text (Range.linear 0 256) Gen.unicode++genMethod :: Gen Method+genMethod = Gen.element+  [methodGet, methodPost, methodPut, methodDelete, methodPatch, methodHead]++genPathSegment :: Gen Text+genPathSegment = Gen.text (Range.linear 1 20) Gen.alphaNum++genPath :: Gen [Text]+genPath = Gen.list (Range.linear 0 5) genPathSegment++genQuery :: Gen Query+genQuery = Gen.list (Range.linear 0 5) $ do+  k <- Gen.bytes (Range.linear 1 20)+  mv <- Gen.maybe (Gen.bytes (Range.linear 0 50))+  pure (k, mv)++genHeader :: Gen Header+genHeader = do+  name <- Gen.element ["Content-Type", "Accept", "Authorization", "X-Custom"]+  val <- Gen.bytes (Range.linear 1 50)+  pure (name, val)++genHeaders :: Gen RequestHeaders+genHeaders = Gen.list (Range.linear 0 5) genHeader+++-- ===================================================================+-- Properties+-- ===================================================================++-- 1. Insert a value into Extensions, lookup returns Just that value.+prop_extensionsInsertLookup :: Property+prop_extensionsInsertLookup = property $ do+  n <- forAll genInt+  val <- evalIO $ do+    exts <- emptyExtensions+    insertExtension (TestVal n) exts+    lookupExtension @TestVal exts+  val === Just (TestVal n)++-- 2. Insert twice with the same type, lookup returns the second value.+prop_extensionsOverwrite :: Property+prop_extensionsOverwrite = property $ do+  n1 <- forAll genInt+  n2 <- forAll genInt+  val <- evalIO $ do+    exts <- emptyExtensions+    insertExtension (TestVal n1) exts+    insertExtension (TestVal n2) exts+    lookupExtension @TestVal exts+  val === Just (TestVal n2)++-- 3. Insert then delete, lookup returns Nothing.+prop_extensionsDeleteLookup :: Property+prop_extensionsDeleteLookup = property $ do+  n <- forAll genInt+  val <- evalIO $ do+    exts <- emptyExtensions+    insertExtension (TestVal n) exts+    deleteExtension @TestVal exts+    lookupExtension @TestVal exts+  val === (Nothing :: Maybe TestVal)++-- 4. fromBytes roundtrip: bodyToStrict (fromBytes bs) == bs+prop_bodyFromBytesRoundtrip :: Property+prop_bodyFromBytesRoundtrip = property $ do+  bs <- forAll genByteString+  result <- evalIO $ bodyToStrict (fromBytes bs)+  result === bs++-- 5. fromText roundtrip: bodyToStrict (fromText t) == encodeUtf8 t+prop_bodyFromTextRoundtrip :: Property+prop_bodyFromTextRoundtrip = property $ do+  t <- forAll genText+  result <- evalIO $ bodyToStrict (fromText t)+  result === TE.encodeUtf8 t++-- 6. streamFromList roundtrip: concat of chunks+prop_streamFromListRoundtrip :: Property+prop_streamFromListRoundtrip = property $ do+  chunks <- forAll $ Gen.list (Range.linear 0 10) genByteString+  result <- evalIO $ do+    body <- streamFromList chunks+    bodyToStrict body+  result === BS.concat chunks++-- 7. isEmptyBody correctness+prop_isEmptyBodyCorrect :: Property+prop_isEmptyBodyCorrect = withTests 1 $ property $ do+  assert (isEmptyBody emptyBody)+  assert (isEmptyBody (fromBytes ""))+  assert (not (isEmptyBody (fromBytes "x")))++-- 8. splitRequest preserves method, path, query, headers+prop_splitRequestPreservesFields :: Property+prop_splitRequestPreservesFields = property $ do+  method  <- forAll genMethod+  path    <- forAll genPath+  query   <- forAll genQuery+  headers <- forAll genHeaders+  body    <- forAll genByteString++  let pathRaw = TE.encodeUtf8 ("/" <> T.intercalate "/" path)++  (parts, splitBody) <- evalIO $ do+    exts <- emptyExtensions+    let req = Request+          { requestMethod     = method+          , requestPathRaw    = pathRaw+          , requestPath       = path+          , requestQuery      = query+          , requestHeaders    = headers+          , requestBody       = body+          , requestExtensions = exts+          }+    pure (splitRequest req)++  rpMethod parts === method+  rpPathRaw parts === pathRaw+  rpPath parts === path+  rpQuery parts === query+  rpHeaders parts === headers+  splitBody === body+++-- ===================================================================+-- Main — TemplateHaskell discovery+-- ===================================================================++tests :: IO Bool+tests = checkParallel $$(discover)++main :: IO ()+main = do+  passed <- tests+  if passed+    then pure ()+    else error "Property tests failed"