diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/http-core.cabal b/http-core.cabal new file mode 100644 --- /dev/null +++ b/http-core.cabal @@ -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 +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 diff --git a/src/Http/Core.hs b/src/Http/Core.hs new file mode 100644 --- /dev/null +++ b/src/Http/Core.hs @@ -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) diff --git a/src/Http/Core/Body.hs b/src/Http/Core/Body.hs new file mode 100644 --- /dev/null +++ b/src/Http/Core/Body.hs @@ -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 diff --git a/src/Http/Core/Extensions.hs b/src/Http/Core/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Http/Core/Extensions.hs @@ -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 #-} diff --git a/src/Http/Core/Request.hs b/src/Http/Core/Request.hs new file mode 100644 --- /dev/null +++ b/src/Http/Core/Request.hs @@ -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 + } diff --git a/src/Http/Core/Response.hs b/src/Http/Core/Response.hs new file mode 100644 --- /dev/null +++ b/src/Http/Core/Response.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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." diff --git a/test/Properties.hs b/test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Properties.hs @@ -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"