packages feed

spire-server (empty) → 0.1.0.0

raw patch · 10 files changed

+1412/−0 lines, 10 filesdep +asyncdep +attoparsecdep +base

Dependencies added: async, attoparsec, base, bytestring, case-insensitive, data-default-class, hedgehog, http-client, http-core, http-semantics, http-types, http2, network, network-run, spire, spire-server, text, time-manager, tls

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Revision history for spire-server++## 0.1.0.0 -- 2026-04-27++* Initial release. Hand-rolled HTTP server backend for spire: parses+  requests, dispatches to a Service, and renders responses without+  pulling in warp or wai.
+ 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.
+ spire-server.cabal view
@@ -0,0 +1,107 @@+cabal-version:   3.0+name:            spire-server+version:         0.1.0.0+synopsis:        Spire-native HTTP/1.1 + HTTP/2 server, no WAI dependency+category:        Network.HTTP+description:+  A lightweight HTTP server that speaks spire Service directly.+  No WAI, no warp: just network sockets, HTTP parsing, and dispatch+  to @Service IO (Request Body) (Response Body)@.+  .+  Supports HTTP/1.1 (custom parser), HTTP/2 (via the @http2@ package),+  TLS with ALPN protocol negotiation, and automatic HTTP/1.1 vs HTTP/2+  detection.+  .+  Proves the zero-WAI path: the entire acolyte stack+  (including gRPC) can run without any WAI dependency.++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:+    Spire.Server+    Spire.Server.Parse+    Spire.Server.Render+    Spire.Server.TLS+    Spire.Server.H2++  build-depends:+      base               >= 4.20 && < 5+    , spire              >= 0.1  && < 0.2+    , http-core          >= 0.1  && < 0.2+    , network            >= 3.1  && < 3.3+    , bytestring         >= 0.11 && < 0.13+    , text               >= 2.0  && < 2.2+    , http-types         >= 0.12 && < 0.13+    , attoparsec         >= 0.14 && < 0.15+    , case-insensitive   >= 1.2  && < 1.3+    , tls                >= 2.0  && < 2.2+    , data-default-class >= 0.1  && < 0.2+    , http2              >= 5.3  && < 5.5+    , http-semantics     >= 0.2  && < 0.3+    , network-run        >= 0.4  && < 0.5+    , async              >= 2.2  && < 2.3+    , time-manager       >= 0.1  && < 0.2++  hs-source-dirs: src+  default-language: GHC2024+  default-extensions:+    OverloadedStrings+    StrictData++  -- -fno-full-laziness: spire-server has streaming response rendering+  -- (chunked transfer encoding, HTTP/2 streaming) where full laziness+  -- could theoretically float IO actions out of lambdas.+  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:+    OverloadedStrings+    StrictData++  ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K"++  build-depends:+      base         >= 4.20 && < 5+    , spire-server >= 0.1  && < 0.2+    , spire        >= 0.1  && < 0.2+    , http-core    >= 0.1  && < 0.2+    , network      >= 3.1  && < 3.3+    , bytestring   >= 0.11 && < 0.13+    , text         >= 2.0  && < 2.2+    , http-types   >= 0.12 && < 0.13+    , http-client  >= 0.7  && < 0.8++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+    , spire-server      >= 0.1  && < 0.2+    , hedgehog          >= 1.4  && < 1.8+    , bytestring        >= 0.11 && < 0.13+    , http-types        >= 0.12 && < 0.13+    , case-insensitive  >= 1.2  && < 1.3++source-repository head+  type:     git+  location: https://github.com/joshburgess/acolyte.git
+ src/Spire/Server.hs view
@@ -0,0 +1,301 @@+-- | Minimal spire-native HTTP/1.1 server — no WAI dependency.+--+-- Accepts TCP connections, parses HTTP/1.1, dispatches to a spire+-- Service, and writes HTTP/1.1 responses. Supports keep-alive and+-- graceful shutdown.+--+-- @+-- import Spire.Server (runServer)+-- import Spire (Service (..))+-- import Http.Core+--+-- main :: IO ()+-- main = runServer 3000 $ Service $ \req ->+--   pure (Response status200 [("Content-Type", "text/plain")] (fromBytes "hello"))+-- @+module Spire.Server+  ( -- * Running the server (Body-based — native)+    runServer+  , runServerWithShutdown+    -- * Running the server (ByteString-based — convenient)+  , runServerBS+  , runServerConfigBS+    -- * Body adapter+  , adaptToBody+    -- * Configuration+  , ServerConfig (..)+  , defaultConfig+  , runServerConfig+  ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Exception (bracket, catch, SomeException, finally)+import System.Timeout (timeout)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Char (toLower)+import Data.IORef+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types (status400, status408, status500, statusCode, Query, parseQuery, urlDecode)+import Network.Socket+import Network.Socket.ByteString (recv, sendAll)++import Spire.Service (Service (..))+import Http.Core+import Http.Core.Body+import Spire.Server.Parse+  ( parseRequestHead, RequestHead (..), readBody+  , readRequestHead, ParseLimits (..), defaultParseLimits+  )+import Spire.Server.Render (renderFull, sendResponse)+++-- | Server configuration.+data ServerConfig = ServerConfig+  { configPort            :: !Int+  , configHost            :: !HostName+  , configMaxBodySize     :: !Int       -- ^ Max request body (bytes). Default: 2 MiB.+  , configRecvBufferSize  :: !Int       -- ^ Socket receive buffer. Default: 4096.+  , configKeepAlive       :: !Bool      -- ^ Support HTTP keep-alive. Default: True.+  , configHeaderTimeout   :: !Int       -- ^ Max microseconds to read headers. Default: 30s. (slow loris protection)+  , configIdleTimeout     :: !Int       -- ^ Max microseconds idle between keep-alive requests. Default: 60s.+  , configOnException     :: !(SomeException -> IO ())  -- ^ Exception handler. Default: ignore.+  }++-- | Access the exception handler (avoids record selector ambiguity).+onException :: ServerConfig -> SomeException -> IO ()+onException = configOnException++-- | Default server configuration for the given port, binding to @127.0.0.1@.+defaultConfig :: Int -> ServerConfig+defaultConfig port = ServerConfig+  { configPort           = port+  , configHost           = "127.0.0.1"+  , configMaxBodySize    = 2 * 1024 * 1024+  , configRecvBufferSize = 4096+  , configKeepAlive      = True+  , configHeaderTimeout  = 30 * 1000000   -- 30 seconds+  , configIdleTimeout    = 60 * 1000000   -- 60 seconds+  , configOnException    = \_ -> pure ()+  }+++-- | Run the server on the given port.+--+-- For long-running production deployments, run with these RTS options:+--+-- @+-- +RTS -Fd30 --nonmoving-gc -RTS+-- @+--+-- * @-Fd30@ returns unused memory to the OS every 30 seconds+--   (prevents resident memory from staying high after traffic spikes)+-- * @--nonmoving-gc@ uses the non-moving garbage collector for lower+--   GC pause latency (important for request-serving processes)+runServer :: Int -> Service IO (Request Body) (Response Body) -> IO ()+runServer port svc = runServerConfig (defaultConfig port) svc+++-- | Run with a shutdown signal (MVar becomes full to trigger shutdown).+runServerWithShutdown+  :: ServerConfig+  -> Service IO (Request Body) (Response Body)+  -> MVar ()  -- ^ Put () to trigger shutdown+  -> IO ()+runServerWithShutdown config svc shutdownVar = do+  let hints = defaultHints+        { addrFlags = [AI_PASSIVE]+        , addrSocketType = Stream+        }+  addr:_ <- getAddrInfo (Just hints) (Just (configHost config)) (Just (show (configPort config)))+  bracket (openSocket addr) close $ \sock -> do+    setSocketOption sock ReuseAddr 1+    bind sock (addrAddress addr)+    listen sock 128++    -- Accept loop+    activeConns <- newIORef (0 :: Int)+    let loop = do+          -- Check for shutdown+          shutdown <- tryReadMVar shutdownVar+          case shutdown of+            Just _  -> waitForConns activeConns+            Nothing -> do+              -- Accept with timeout so we can check shutdown periodically+              result <- catch+                (Just <$> accept sock)+                (\(_ :: SomeException) -> pure Nothing)+              case result of+                Nothing -> loop+                Just (conn, _addr) -> do+                  atomicModifyIORef' activeConns (\n -> (n + 1, ()))+                  _ <- forkIO $ handleConnection config svc conn+                    `finally` atomicModifyIORef' activeConns (\n -> (n - 1, ()))+                  loop+    loop+++-- | Run with default shutdown behavior (runs forever until killed).+runServerConfig :: ServerConfig -> Service IO (Request Body) (Response Body) -> IO ()+runServerConfig config svc = do+  let hints = defaultHints+        { addrFlags = [AI_PASSIVE]+        , addrSocketType = Stream+        }+  addr:_ <- getAddrInfo (Just hints) (Just (configHost config)) (Just (show (configPort config)))+  bracket (openSocket addr) close $ \sock -> do+    setSocketOption sock ReuseAddr 1+    bind sock (addrAddress addr)+    listen sock 128+    acceptLoop config svc sock+++-- | Accept connections forever.+acceptLoop :: ServerConfig -> Service IO (Request Body) (Response Body) -> Socket -> IO ()+acceptLoop config svc sock = do+  (conn, _addr) <- accept sock+  _ <- forkIO $ handleConnection config svc conn+  acceptLoop config svc sock+++-- | Handle a single connection (possibly multiple requests via keep-alive).+--+-- Known limitation: HTTP pipelining (multiple requests sent before any+-- response is read) is not supported. If the client pipelines requests,+-- leftover bytes from the body read (belonging to the next pipelined+-- request) are discarded. In practice this is not an issue: browsers+-- do not pipeline HTTP/1.1 requests, and HTTP/2 supersedes pipelining.+-- The keep-alive loop only handles sequential request-response pairs.+handleConnection+  :: ServerConfig+  -> Service IO (Request Body) (Response Body)+  -> Socket+  -> IO ()+handleConnection config svc conn = go `finally` close conn+  where+    limits = ParseLimits+      { maxHeaderSize = 8 * 1024+      , maxBodySize   = configMaxBodySize config+      , recvBufSize   = configRecvBufferSize config+      }++    go = do+      -- Read headers with timeout (slow loris protection)+      mResult <- timeout (configHeaderTimeout config) (readRequestHead conn limits)+      case mResult of+        Nothing -> do+          -- Header read timed out+          sendAll conn (renderFull status408 [] "Request Timeout")+        Just (Left errMsg) -> do+          -- Parse error+          sendAll conn (renderFull status400 [] errMsg)+        Just (Right (reqHead, remainder)) -> do+          -- Read body with limits+          bodyResult <- readBody conn limits (rhHeaders reqHead) remainder+          case bodyResult of+            Left errMsg -> do+              sendAll conn (renderFull status400 [] errMsg)+            Right body -> do+              -- Build our Request+              exts <- emptyExtensions+              let pathRaw = rhPath reqHead+                  (pathPart, queryPart) = BS8.break (== '?') pathRaw+                  path = filter (/= "") $ map (TE.decodeUtf8Lenient . urlDecode True) $ BS.split 0x2F pathPart+                  query = parseQueryString (BS.drop 1 queryPart)+                  req = Request+                    { requestMethod     = rhMethod reqHead+                    , requestPathRaw    = pathPart+                    , requestPath       = path+                    , requestQuery      = query+                    , requestHeaders    = rhHeaders reqHead+                    , requestBody       = fromBytes body+                    , requestExtensions = exts+                    }++              -- Dispatch to spire Service (catch handler exceptions)+              resp <- catch+                (runService svc req)+                (\(e :: SomeException) -> do+                  onException config e+                  pure (Response status500+                    [("Content-Type", "text/plain")]+                    (fromBytes "Internal Server Error")))++              -- Render and send response (streaming or strict)+              sendResponse (sendAll conn)+                (responseStatus resp)+                (responseHeaders resp)+                (responseBody resp)++              -- Keep-alive: check Connection header (case-insensitive)+              let connHeader = lookup "connection" (rhHeaders reqHead)+                  isClose = case connHeader of+                    Just v  -> BS8.map toLower v == "close"+                    Nothing -> False+                  keepAlive = configKeepAlive config && not isClose+              if keepAlive+                then go+                else pure ()+++-- | Parse a query string (without the leading '?').+parseQueryString :: ByteString -> Query+parseQueryString bs+  | BS.null bs = []+  | otherwise  = parseQuery bs+++-- | Wait for all active connections to finish.+waitForConns :: IORef Int -> IO ()+waitForConns ref = do+  n <- readIORef ref+  if n > 0+    then threadDelay 100000 >> waitForConns ref  -- 100ms poll+    else pure ()+++-- ===================================================================+-- ByteString convenience: no manual Body adapter needed+-- ===================================================================++-- | Run a ByteString-based service on spire-server.+--+-- This is the convenient entry point for services built with+-- acolyte-server (which produces @Service IO (Request+-- ByteString) (Response ByteString)@). The Body conversion is+-- handled internally — users never see the Body type.+--+-- @+-- main = runServerBS 3000 myService+-- @+runServerBS :: Int -> Service IO (Request ByteString) (Response ByteString) -> IO ()+runServerBS port svc = runServer port (adaptToBody svc)+++-- | Run a ByteString-based service with full config.+runServerConfigBS :: ServerConfig -> Service IO (Request ByteString) (Response ByteString) -> IO ()+runServerConfigBS config svc = runServerConfig config (adaptToBody svc)+++-- | Adapt a ByteString-based service to a Body-based service.+--+-- Converts the request body from Body to ByteString (collecting+-- streaming bodies), and wraps the ByteString response body as+-- a strict Body.+--+-- This is the bridge between acolyte-server (which works+-- with strict ByteString) and spire-server (which works with Body).+adaptToBody+  :: Service IO (Request ByteString) (Response ByteString)+  -> Service IO (Request Body) (Response Body)+adaptToBody (Service f) = Service $ \req -> do+  bodyBytes <- bodyToStrict (requestBody req)+  let bsReq = req { requestBody = bodyBytes }+  resp <- f bsReq+  pure resp { responseBody = fromBytes (responseBody resp) }++
+ src/Spire/Server/H2.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE OverloadedStrings #-}+-- | HTTP/2 server support via the @http2@ package.+--+-- Bridges the @http2@ library's callback-based server API to spire's+-- @Service IO (Request Body) (Response Body)@ abstraction. The same+-- spire Service that handles HTTP/1.1 requests handles HTTP/2 — no+-- code changes needed.+--+-- @+-- import Spire.Server.H2 (runServerH2, defaultH2Config)+--+-- main = runServerH2 (defaultH2Config 3000) myService+-- @+module Spire.Server.H2+  ( -- * Configuration+    H2Config (..)+  , defaultH2Config+    -- * Running+  , runServerH2+    -- * Bridge (for custom setups)+  , toH2Server+  ) where++import Control.Concurrent (forkIO)+import Control.Exception (bracket, catch, SomeException, finally)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as Builder+import qualified Data.CaseInsensitive as CI+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types (status500, parseQuery, urlDecode)+import Network.Socket++import qualified Network.HTTP2.Server as H2+import Network.HTTP.Semantics (Token(..))++import Spire.Service (Service (..))+import Http.Core+import Http.Core.Body+++-- | HTTP/2 server configuration.+data H2Config = H2Config+  { h2Port         :: !Int+  , h2Host         :: !Text+  , h2Workers      :: !Int+  , h2MaxStreams    :: !Int+  } deriving (Show)++-- | Sensible defaults for HTTP/2.+defaultH2Config :: Int -> H2Config+defaultH2Config port = H2Config+  { h2Port      = port+  , h2Host      = "127.0.0.1"+  , h2Workers   = 4+  , h2MaxStreams = 100+  }+++-- | Run an HTTP/2 server (h2c — cleartext, no TLS).+--+-- Listens on the configured port and dispatches each HTTP/2 stream+-- to the spire Service.+runServerH2 :: H2Config -> Service IO (Request Body) (Response Body) -> IO ()+runServerH2 config svc = do+  let hints = defaultHints { addrSocketType = Stream }+  addr:_ <- getAddrInfo (Just hints)+    (Just (T.unpack (h2Host config)))+    (Just (show (h2Port config)))+  bracket (openSocket addr) close $ \sock -> do+    setSocketOption sock ReuseAddr 1+    bind sock (addrAddress addr)+    listen sock 128+    acceptLoopH2 config svc sock+++acceptLoopH2 :: H2Config -> Service IO (Request Body) (Response Body) -> Socket -> IO ()+acceptLoopH2 config svc sock = do+  (conn, _addr) <- accept sock+  _ <- forkIO $ handleH2Connection config svc conn+  acceptLoopH2 config svc sock+++handleH2Connection+  :: H2Config+  -> Service IO (Request Body) (Response Body)+  -> Socket+  -> IO ()+handleH2Connection _config svc conn =+  (do h2Conf <- H2.allocSimpleConfig conn 4096+      H2.run H2.defaultServerConfig h2Conf (toH2Server svc)+      H2.freeSimpleConfig h2Conf)+    `catch` (\(_ :: SomeException) -> pure ())+    `finally` close conn+++-- | Bridge a spire Service to the http2 package's Server callback.+--+-- Each HTTP/2 stream (request) is dispatched to the spire Service,+-- and the response is sent back via the http2 callback.+toH2Server :: Service IO (Request Body) (Response Body) -> H2.Server+toH2Server (Service handler) h2Req _aux respond = do+  resp <- (do+    req <- fromH2Request h2Req+    handler req)+    `catch` (\(_ :: SomeException) ->+      pure (Http.Core.Response status500+        [("Content-Type", "text/plain")]+        (fromBytes "Internal Server Error")))+  respond (toH2Response resp) []+++-- | Convert an http2 Request to an http-core Request.+fromH2Request :: H2.Request -> IO (Request Body)+fromH2Request h2Req = do+  exts <- emptyExtensions+  let method  = maybe "GET" id (H2.requestMethod h2Req)+      pathRaw = maybe "/" id (H2.requestPath h2Req)+      (pathPart, queryPart) = BS.break (== 0x3F) pathRaw+      pathSegs = filter (/= "") $ map (TE.decodeUtf8Lenient . urlDecode True) $ BS.split 0x2F pathPart+      query = if BS.null queryPart then [] else parseQuery (BS.drop 1 queryPart)+      -- TokenHeaderList = [(Token, FieldValue)]+      -- Token has tokenKey :: CI ByteString, isPseudo :: Bool+      (tokenList, _valueTable) = H2.requestHeaders h2Req+      -- Filter out pseudo-headers (:method, :path, :scheme, :authority)+      headers = [ (tokenKey tok, val)+                | (tok, val) <- tokenList+                , not (isPseudo tok)+                ]+  let bodyStream = streamBody $ do+        chunk <- H2.getRequestBodyChunk h2Req+        if BS.null chunk+          then pure Nothing+          else pure (Just (Chunk chunk))+  pure Http.Core.Request+    { requestMethod     = method+    , requestPathRaw    = pathPart+    , requestPath       = pathSegs+    , requestQuery      = query+    , requestHeaders    = headers+    , requestBody       = bodyStream+    , requestExtensions = exts+    }+++-- | Convert an http-core Response to an http2 Response.+toH2Response :: Response Body -> H2.Response+toH2Response resp =+  let status = responseStatus resp+      hdrs   = responseHeaders resp+  in case responseBody resp of+    BodyEmpty ->+      H2.responseNoBody status hdrs+    BodyStrict bs ->+      H2.responseBuilder status hdrs (Builder.byteString bs)+    BodyStream pull ->+      H2.responseStreaming status hdrs $ \write flush -> do+        let go = do+              mChunk <- pull+              case mChunk of+                Nothing          -> flush+                Just (Chunk bs)  -> write (Builder.byteString bs) >> go+                Just ChunkFlush  -> flush >> go+        go+    BodyFile path mRange ->+      case mRange of+        Nothing ->+          H2.responseFile status hdrs (H2.FileSpec path 0 maxBound)+        Just (FileRange off len) ->+          H2.responseFile status hdrs+            (H2.FileSpec path (fromIntegral off) (fromIntegral len))
+ src/Spire/Server/Parse.hs view
@@ -0,0 +1,233 @@+-- | HTTP/1.1 request parsing.+--+-- Handles: Content-Length bodies, chunked transfer-encoding,+-- incremental header reading (headers may arrive across multiple+-- recv() calls), header size limits, and malformed request rejection.+module Spire.Server.Parse+  ( -- * Parsing+    parseRequestHead+  , RequestHead (..)+  , readBody+    -- * Incremental reading+  , readRequestHead+    -- * Limits+  , ParseLimits (..)+  , defaultParseLimits+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.CaseInsensitive as CI+import Data.Word (Word8)+import Network.HTTP.Types (RequestHeaders, Header, HeaderName)+import Network.Socket (Socket)+import Network.Socket.ByteString (recv)+import Numeric (readHex)+++-- | Parsed request head (method, path, version, headers).+data RequestHead = RequestHead+  { rhMethod  :: !ByteString+  , rhPath    :: !ByteString+  , rhVersion :: !ByteString+  , rhHeaders :: !RequestHeaders+  } deriving (Show)+++-- | Limits for parsing.+data ParseLimits = ParseLimits+  { maxHeaderSize :: !Int    -- ^ Max total header size in bytes. Default: 8 KiB.+  , maxBodySize   :: !Int    -- ^ Max request body size. Default: 2 MiB.+  , recvBufSize   :: !Int    -- ^ Socket receive buffer size. Default: 4096.+  } deriving (Show)++-- | Default parse limits: 8 KiB headers, 2 MiB body, 4096-byte recv buffer.+defaultParseLimits :: ParseLimits+defaultParseLimits = ParseLimits+  { maxHeaderSize = 8 * 1024+  , maxBodySize   = 2 * 1024 * 1024+  , recvBufSize   = 4096+  }+++-- | Parse the request line and headers from a buffer.+--+-- Returns the parsed head and any leftover bytes (start of body).+-- Returns Nothing if the input is malformed.+parseRequestHead :: ByteString -> Maybe (RequestHead, ByteString)+parseRequestHead input = do+  idx <- findSubstring "\r\n\r\n" input+  let headerSection = BS.take idx input+      remainder = BS.drop (idx + 4) input++  let ls = BS8.lines headerSection+  case ls of+    [] -> Nothing+    (reqLine : headerLines) -> do+      (method, path, ver) <- parseRequestLine reqLine+      let headers = map parseHeaderLine (filter (not . BS.null) headerLines)+      Just (RequestHead method path ver headers, remainder)+++-- | Read the request head incrementally from a socket.+--+-- Keeps reading until the header terminator (\r\n\r\n) is found+-- or the header size limit is exceeded.+--+-- Returns Left error message on failure, Right (head, leftover) on success.+readRequestHead :: Socket -> ParseLimits -> IO (Either ByteString (RequestHead, ByteString))+readRequestHead sock limits = go BS.empty+  where+    go buf+      | BS.length buf > maxHeaderSize limits =+          pure (Left "431 Request Header Fields Too Large")+      | otherwise =+          case findSubstring "\r\n\r\n" buf of+            Just _ -> case parseRequestHead buf of+              Just result -> pure (Right result)+              Nothing     -> pure (Left "400 Bad Request: malformed request line or headers")+            Nothing -> do+              chunk <- recv sock (recvBufSize limits)+              if BS.null chunk+                then pure (Left "400 Bad Request: connection closed before headers complete")+                else go (buf <> chunk)+++-- | Parse "GET /path HTTP/1.1\r"+parseRequestLine :: ByteString -> Maybe (ByteString, ByteString, ByteString)+parseRequestLine line = case BS8.words (stripCR line) of+  [method, path, version] -> Just (method, path, version)+  _ -> Nothing+++-- | Parse "Header-Name: value\r"+parseHeaderLine :: ByteString -> Header+parseHeaderLine line =+  let cleaned = stripCR line+  in case BS8.break (== ':') cleaned of+    (name, rest)+      | BS.null rest -> (CI.mk name, "")+      | otherwise    -> (CI.mk name, BS8.dropWhile (== ' ') (BS.drop 1 rest))+++-- | Read the request body based on Content-Length or Transfer-Encoding.+readBody :: Socket -> ParseLimits -> RequestHeaders -> ByteString -> IO (Either ByteString ByteString)+readBody sock limits headers leftover+  -- Chunked transfer encoding+  | isChunked headers = readChunkedBody sock limits leftover+  -- Content-Length+  | Just clBS <- lookup "content-length" headers =+      case reads (BS8.unpack clBS) of+        [(cl, "")]+          | cl > maxBodySize limits -> pure (Left "413 Payload Too Large")+          | cl == 0                 -> pure (Right BS.empty)+          | otherwise               -> readExactly sock cl leftover+        _ -> pure (Left "400 Bad Request: invalid Content-Length")+  -- No body+  | otherwise = pure (Right BS.empty)+++-- | Check if the request uses chunked transfer encoding.+isChunked :: RequestHeaders -> Bool+isChunked headers =+  case lookup "transfer-encoding" headers of+    Just te -> BS8.isInfixOf "chunked" te+    Nothing -> False+++-- | Read a chunked transfer-encoded body.+--+-- Chunk format: {hex-size}\r\n{data}\r\n+-- Final chunk:  0\r\n\r\n+readChunkedBody :: Socket -> ParseLimits -> ByteString -> IO (Either ByteString ByteString)+readChunkedBody sock limits = go BS.empty+  where+    go acc buf+      | BS.length acc > maxBodySize limits = pure (Left "413 Payload Too Large")+      | otherwise =+          case findSubstring "\r\n" buf of+            Nothing -> do+              chunk <- recv sock (recvBufSize limits)+              if BS.null chunk+                then pure (Left "400 Bad Request: incomplete chunked body")+                else go acc (buf <> chunk)+            Just idx -> do+              let sizeLine = BS.take idx buf+                  rest = BS.drop (idx + 2) buf+              case readHex (BS8.unpack sizeLine) of+                [(0, "")] -> pure (Right acc)  -- final chunk+                [(n, "")] | n > maxBodySize limits - BS.length acc ->+                  pure (Left "413 Payload Too Large")+                [(n, "")] -> do+                  -- Read n bytes of chunk data + trailing \r\n+                  let needed = n + 2  -- data + \r\n+                  ensureResult <- ensureBytes sock (recvBufSize limits) needed rest+                  case ensureResult of+                    Left err -> pure (Left err)+                    Right fullChunk -> do+                      let chunkData = BS.take n fullChunk+                          remaining = BS.drop (n + 2) fullChunk+                      go (acc <> chunkData) remaining+                _ -> pure (Left "400 Bad Request: invalid chunk size")+++-- | Ensure we have at least n bytes, reading from socket if needed.+-- Returns Left if the connection closed before enough bytes arrived.+ensureBytes :: Socket -> Int -> Int -> ByteString -> IO (Either ByteString ByteString)+ensureBytes sock bufSize needed buf+  | BS.length buf >= needed = pure (Right buf)+  | otherwise = do+      chunk <- recv sock bufSize+      if BS.null chunk+        then pure (Left "400 Bad Request: connection closed before chunk data complete")+        else ensureBytes sock bufSize needed (buf <> chunk)+++-- | Read exactly n bytes from leftover + socket.+-- Returns Left if the connection closed before enough bytes arrived.+readExactly :: Socket -> Int -> ByteString -> IO (Either ByteString ByteString)+readExactly sock n leftover+  | BS.length leftover >= n = pure (Right (BS.take n leftover))+  | otherwise = do+      let needed = n - BS.length leftover+      more <- recvAll sock needed+      let result = leftover <> BS.take needed more+      if BS.length result < n+        then pure (Left "400 Bad Request: connection closed before body complete")+        else pure (Right result)+++-- | Receive at least n bytes from a socket.+recvAll :: Socket -> Int -> IO ByteString+recvAll sock n = go BS.empty+  where+    go acc+      | BS.length acc >= n = pure acc+      | otherwise = do+          chunk <- recv sock 4096+          if BS.null chunk+            then pure acc+            else go (acc <> chunk)+++-- ===================================================================+-- Helpers+-- ===================================================================++stripCR :: ByteString -> ByteString+stripCR bs+  | BS.null bs = bs+  | BS.last bs == 13 = BS.init bs+  | otherwise = bs++-- | Find the index of a substring in a ByteString.+findSubstring :: ByteString -> ByteString -> Maybe Int+findSubstring needle haystack = go 0+  where+    nLen = BS.length needle+    hLen = BS.length haystack+    go i+      | i + nLen > hLen = Nothing+      | BS.take nLen (BS.drop i haystack) == needle = Just i+      | otherwise = go (i + 1)
+ src/Spire/Server/Render.hs view
@@ -0,0 +1,137 @@+-- | HTTP/1.1 response rendering.+module Spire.Server.Render+  ( -- * Full response (strict body)+    renderFull+    -- * Streaming response (chunked transfer encoding)+  , sendResponseStreaming+    -- * Response head+  , renderResponseHead+    -- * Combined (picks strategy based on Body type)+  , sendResponse+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Builder.Extra as BuilderEx+import qualified Data.ByteString.Lazy as LBS+import qualified Data.CaseInsensitive as CI+import Network.HTTP.Types (Status, statusCode, statusMessage, ResponseHeaders, Header)+import Numeric (showHex)++import Http.Core.Body (Body (..), BodyChunk (..), bodyToStrict)+++-- | Send a response over a socket, choosing the right strategy.+--+-- * Strict/Empty/File → Content-Length, single write+-- * Stream → chunked transfer encoding, multiple writes+sendResponse :: (ByteString -> IO ()) -> Status -> ResponseHeaders -> Body -> IO ()+sendResponse send status headers body = case body of+  BodyStrict bs -> send (renderFull status headers bs)+  BodyEmpty     -> send (renderFull status headers BS.empty)+  BodyFile _ _  -> do+    bs <- bodyToStrict body+    send (renderFull status headers bs)+  BodyStream pull ->+    sendResponseStreaming send status headers pull+++-- | Render a complete response with Content-Length (strict bodies).+--+-- Uses a tuned buffer strategy: 4KB initial allocation covers most+-- HTTP responses in a single chunk, avoiding the double-copy of+-- @LBS.toStrict . Builder.toLazyByteString@.+renderFull :: Status -> ResponseHeaders -> ByteString -> ByteString+renderFull status headers body =+  toStrictBuilder $+    renderStatusLine status+    <> renderHeaders (addContentLength (BS.length body) headers)+    <> Builder.byteString "\r\n"+    <> Builder.byteString body+++-- | Send a streaming response using chunked transfer encoding.+--+-- HTTP/1.1 chunked format:+--   {hex-length}\r\n{data}\r\n   (per chunk)+--   0\r\n\r\n                     (final chunk)+sendResponseStreaming+  :: (ByteString -> IO ())  -- ^ Socket send function+  -> Status+  -> ResponseHeaders+  -> IO (Maybe BodyChunk)   -- ^ Pull-based chunk producer+  -> IO ()+sendResponseStreaming send status headers pull = do+  -- Send headers with Transfer-Encoding: chunked+  let hdrs = ("Transfer-Encoding", "chunked") : headers+  send (renderResponseHead status hdrs)++  -- Send chunks+  let loop = do+        mChunk <- pull+        case mChunk of+          Nothing -> do+            -- Final chunk: 0\r\n\r\n+            send "0\r\n\r\n"+          Just (Chunk bs) | BS.null bs -> loop  -- skip empty chunks+          Just (Chunk bs) -> do+            -- {hex-length}\r\n{data}\r\n+            let len = BS8.pack (showHex (BS.length bs) "")+            send (len <> "\r\n" <> bs <> "\r\n")+            loop+          Just ChunkFlush -> loop  -- flush hint — we send immediately anyway+  loop+++-- | Render status line + headers (no body, no trailing CRLF for streaming).+renderResponseHead :: Status -> ResponseHeaders -> ByteString+renderResponseHead status headers =+  toStrictBuilder $+    renderStatusLine status+    <> renderHeaders headers+    <> Builder.byteString "\r\n"+++-- ===================================================================+-- Internal+-- ===================================================================++renderStatusLine :: Status -> Builder.Builder+renderStatusLine status =+  Builder.byteString "HTTP/1.1 "+  <> Builder.intDec (statusCode status)+  <> Builder.byteString " "+  <> Builder.byteString (statusMessage status)+  <> Builder.byteString "\r\n"++renderHeaders :: ResponseHeaders -> Builder.Builder+renderHeaders = foldMap renderHeader++renderHeader :: Header -> Builder.Builder+renderHeader (name, value) =+  Builder.byteString (CI.original name)+  <> Builder.byteString ": "+  <> Builder.byteString value+  <> Builder.byteString "\r\n"++addContentLength :: Int -> ResponseHeaders -> ResponseHeaders+addContentLength len headers+  | any (\(k, _) -> k == "content-length") headers = headers+  | otherwise = ("Content-Length", BS8.pack (show len)) : headers+++-- | Convert a Builder to strict ByteString with a tuned buffer strategy.+--+-- Uses a 4KB initial buffer (covers most HTTP headers + small JSON bodies+-- in a single allocation) with small-chunks growth strategy. This avoids+-- the overhead of @LBS.toStrict . Builder.toLazyByteString@ which allocates+-- a lazy bytestring with default 32KB chunks then copies to strict.+toStrictBuilder :: Builder.Builder -> ByteString+toStrictBuilder =+  LBS.toStrict+  . BuilderEx.toLazyByteStringWith+      (BuilderEx.safeStrategy 4096 4096)+      LBS.empty+{-# INLINE toStrictBuilder #-}
+ src/Spire/Server/TLS.hs view
@@ -0,0 +1,120 @@+-- | TLS support for spire-server.+--+-- Accepts a pre-configured @TLS.ServerParams@ so users have full+-- control over cipher suites, certificate loading, and TLS versions.+-- See the @tls@ package documentation for configuration options.+--+-- @+-- import qualified Network.TLS as TLS+-- import qualified Network.TLS.Extra.Cipher as TLS+-- import Spire.Server.TLS+--+-- main = do+--   params <- loadTLSParams "cert.pem" "key.pem"+--   runServerTLS 443 "0.0.0.0" params myService+-- @+module Spire.Server.TLS+  ( -- * Running with TLS+    runServerTLS+    -- * Helper for loading credentials+  , loadTLSParams+  ) where++import Control.Concurrent (forkIO)+import Control.Exception (bracket, catch, finally, SomeException)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types (status400, status500, parseQuery, urlDecode)+import Network.Socket+import qualified Network.TLS as TLS++import Spire.Service (Service (..))+import Http.Core+import Http.Core.Body+import Spire.Server.Parse (parseRequestHead, RequestHead (..))+import Spire.Server.Render (renderFull)+++-- | Run the server with TLS on the given port.+runServerTLS+  :: Int                                    -- ^ Port+  -> HostName                               -- ^ Host+  -> TLS.ServerParams                       -- ^ TLS configuration+  -> Service IO (Request Body) (Response Body)+  -> IO ()+runServerTLS port host params svc = do+  let hints = defaultHints { addrFlags = [AI_PASSIVE], addrSocketType = Stream }+  addr:_ <- getAddrInfo (Just hints) (Just host) (Just (show port))+  bracket (openSocket addr) close $ \sock -> do+    setSocketOption sock ReuseAddr 1+    bind sock (addrAddress addr)+    listen sock 128+    let loop = do+          (conn, _) <- accept sock+          _ <- forkIO $ handleConn params svc conn+          loop+    loop+++-- | Load TLS credentials and build ServerParams.+--+-- Uses strong cipher suites and TLS 1.2+. Returns the error string+-- if credential loading fails.+loadTLSParams :: FilePath -> FilePath -> IO (Either String TLS.ServerParams)+loadTLSParams certFile keyFile = do+  result <- TLS.credentialLoadX509 certFile keyFile+  pure $ case result of+    Left err   -> Left err+    Right cred -> Right $ TLS.defaultParamsServer+      { TLS.serverShared = (TLS.serverShared TLS.defaultParamsServer)+          { TLS.sharedCredentials = TLS.Credentials [cred]+          }+      }+++handleConn :: TLS.ServerParams -> Service IO (Request Body) (Response Body) -> Socket -> IO ()+handleConn params svc sock = (do+  ctx <- TLS.contextNew sock params+  TLS.handshake ctx++  input <- TLS.recvData ctx+  case parseRequestHead input of+    Nothing -> do+      TLS.sendData ctx (LBS.fromStrict $ renderFull status400 [] "Bad Request")+      TLS.bye ctx+    Just (reqHead, remainder) -> do+      let bodyBytes = case lookup "content-length" (rhHeaders reqHead) of+            Just cl -> case reads (BS8.unpack cl) of+              [(n, "")] -> BS.take n remainder+              _         -> BS.empty+            Nothing -> BS.empty++      exts <- emptyExtensions+      let pathRaw = rhPath reqHead+          (pathPart, queryPart) = BS8.break (== '?') pathRaw+          path = filter (/= "") $ map (TE.decodeUtf8Lenient . urlDecode True) $ BS.split 0x2F pathPart+          query = if BS.null queryPart then [] else parseQuery (BS.drop 1 queryPart)+          req = Request+            { requestMethod     = rhMethod reqHead+            , requestPathRaw    = pathPart+            , requestPath       = path+            , requestQuery      = query+            , requestHeaders    = rhHeaders reqHead+            , requestBody       = fromBytes bodyBytes+            , requestExtensions = exts+            }++      resp <- catch+        (runService svc req)+        (\(_ :: SomeException) ->+          pure (Response status500 [("Content-Type", "text/plain")] (fromBytes "Internal Server Error")))++      respBody <- bodyToStrict (responseBody resp)+      TLS.sendData ctx (LBS.fromStrict $ renderFull (responseStatus resp) (responseHeaders resp) respBody)+      TLS.bye ctx+  ) `finally` close sock
+ test/Main.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import Data.Text (Text)+import qualified Data.Text as T+import Network.HTTP.Types+import qualified Network.HTTP.Client as HC++import Spire.Service (Service (..))+import Http.Core+import Http.Core.Body+import Spire.Server+import Spire.Server.Parse+import Spire.Server.Render (renderFull)+++assert :: String -> Bool -> IO ()+assert label True  = putStrLn $ "  OK: " ++ label+assert label False = error   $ "FAIL: " ++ label+++-- ===================================================================+-- Test service+-- ===================================================================++testService :: Service IO (Request Body) (Response Body)+testService = Service $ \req ->+  let path = requestPath req+      method = requestMethod req+  in case (method, path) of+    ("GET", ["health"]) ->+      pure (Response status200 [("Content-Type", "text/plain")] (fromBytes "ok"))++    ("GET", ["users"]) ->+      pure (Response status200 [("Content-Type", "application/json")] (fromBytes "[\"alice\",\"bob\"]"))++    ("GET", ["users", uid]) ->+      pure (Response status200 [("Content-Type", "application/json")]+        (fromBytes (BS8.pack ("\"user-" ++ T.unpack uid ++ "\""))))++    ("POST", ["echo"]) -> do+      body <- bodyToStrict (requestBody req)+      pure (Response status200 [("Content-Type", "application/octet-stream")] (fromBytes body))++    _ -> pure (Response status404 [] (fromBytes "Not Found"))+++-- ===================================================================+-- Parser tests (unit, no network)+-- ===================================================================++testParser :: IO ()+testParser = do+  -- Parse a simple GET request+  let raw = "GET /health HTTP/1.1\r\nHost: localhost\r\nAccept: */*\r\n\r\n"+  case parseRequestHead raw of+    Just (rh, remainder) -> do+      assert "parse: method GET" (rhMethod rh == "GET")+      assert "parse: path /health" (rhPath rh == "/health")+      assert "parse: has Host header" (lookup "host" (rhHeaders rh) == Just "localhost")+      assert "parse: no leftover" (BS.null remainder)+    Nothing -> error "FAIL: parse returned Nothing"++  -- Parse POST with body+  let rawPost = "POST /echo HTTP/1.1\r\nHost: localhost\r\nContent-Length: 5\r\n\r\nhello"+  case parseRequestHead rawPost of+    Just (rh, remainder) -> do+      assert "parse POST: method" (rhMethod rh == "POST")+      assert "parse POST: path" (rhPath rh == "/echo")+      assert "parse POST: content-length header" (lookup "content-length" (rhHeaders rh) == Just "5")+      assert "parse POST: body in remainder" (remainder == "hello")+    Nothing -> error "FAIL: parse POST returned Nothing"+++-- ===================================================================+-- Renderer tests (unit, no network)+-- ===================================================================++testRenderer :: IO ()+testRenderer = do+  let resp = renderFull status200 [("Content-Type", "text/plain")] "hello"+  assert "render: starts with HTTP/1.1 200" (BS.isPrefixOf "HTTP/1.1 200" resp)+  assert "render: contains Content-Length" (BS8.isInfixOf "Content-Length: 5" resp)+  assert "render: ends with body" (BS8.isSuffixOf "hello" resp)++  -- Empty response+  let respEmpty = renderFull status204 [] ""+  assert "render 204: no body" (BS8.isSuffixOf "\r\n\r\n" respEmpty)+++-- ===================================================================+-- Integration test: start server, make real HTTP requests+-- ===================================================================++testIntegration :: IO ()+testIntegration = do+  let port = 18923  -- use a non-standard port+  shutdownVar <- newEmptyMVar++  -- Start server in background+  _ <- forkIO $ runServerWithShutdown (defaultConfig port) testService shutdownVar++  -- Wait for server to start+  threadDelay 200000  -- 200ms++  mgr <- HC.newManager HC.defaultManagerSettings++  -- GET /health+  req1 <- HC.parseRequest ("http://127.0.0.1:" ++ show port ++ "/health")+  resp1 <- HC.httpLbs req1 mgr+  assert "integration: GET /health -> 200" (HC.responseStatus resp1 == status200)+  assert "integration: GET /health body" (HC.responseBody resp1 == "ok")++  -- GET /users+  req2 <- HC.parseRequest ("http://127.0.0.1:" ++ show port ++ "/users")+  resp2 <- HC.httpLbs req2 mgr+  assert "integration: GET /users -> 200" (HC.responseStatus resp2 == status200)+  assert "integration: GET /users body" (HC.responseBody resp2 == "[\"alice\",\"bob\"]")++  -- GET /users/42+  req3 <- HC.parseRequest ("http://127.0.0.1:" ++ show port ++ "/users/42")+  resp3 <- HC.httpLbs req3 mgr+  assert "integration: GET /users/42 -> 200" (HC.responseStatus resp3 == status200)+  assert "integration: GET /users/42 body" (HC.responseBody resp3 == "\"user-42\"")++  -- POST /echo+  let req4 = (HC.parseRequest_ ("http://127.0.0.1:" ++ show port ++ "/echo"))+        { HC.method = "POST"+        , HC.requestBody = HC.RequestBodyLBS "echo-this"+        }+  resp4 <- HC.httpLbs req4 mgr+  assert "integration: POST /echo -> 200" (HC.responseStatus resp4 == status200)+  assert "integration: POST /echo body" (HC.responseBody resp4 == "echo-this")++  -- 404+  req5 <- HC.parseRequest ("http://127.0.0.1:" ++ show port ++ "/nope")+  resp5 <- HC.httpLbs req5 mgr+  assert "integration: GET /nope -> 404" (HC.responseStatus resp5 == status404)++  -- Shutdown+  putMVar shutdownVar ()+  threadDelay 300000  -- let it drain+++-- ===================================================================+-- Main+-- ===================================================================++main :: IO ()+main = do+  putStrLn "spire-server tests:"+  putStrLn ""+  putStrLn "Parser:"+  testParser+  putStrLn ""+  putStrLn "Renderer:"+  testRenderer+  putStrLn ""+  putStrLn "Integration (real HTTP):"+  testIntegration+  putStrLn ""+  putStrLn "All spire-server tests passed."
+ test/Properties.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Control.Exception (evaluate, try, SomeException)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.CaseInsensitive as CI+import Network.HTTP.Types+  ( Status, ResponseHeaders, Header+  , status200, status201, status204, status400, status404, status500+  , statusCode+  )+import Spire.Server.Parse (parseRequestHead, RequestHead(..))+import Spire.Server.Render (renderFull)+++-- ===================================================================+-- Generators+-- ===================================================================++genStatus :: Gen Status+genStatus = Gen.element [status200, status201, status204, status400, status404, status500]++genHeaderName :: Gen ByteString+genHeaderName = Gen.element+  [ "X-Custom", "X-Request-Id", "X-Trace", "Cache-Control", "Accept" ]++genHeaderValue :: Gen ByteString+genHeaderValue = Gen.bytes (Range.linear 1 50)++genHeader :: Gen Header+genHeader = do+  name <- genHeaderName+  value <- genHeaderValue+  pure (CI.mk name, value)++genHeaders :: Gen ResponseHeaders+genHeaders = Gen.list (Range.linear 0 5) genHeader++genBody :: Gen ByteString+genBody = Gen.bytes (Range.linear 0 10000)+++-- ===================================================================+-- Properties+-- ===================================================================++-- | renderFull produces valid HTTP: starts with "HTTP/1.1 ", contains the+-- status code, contains "Content-Length: N" matching body length, and ends+-- with the body bytes.+prop_renderFullValidHttp :: Property+prop_renderFullValidHttp = property $ do+  st <- forAll genStatus+  hdrs <- forAll genHeaders+  body <- forAll genBody+  let rendered = renderFull st hdrs body+      renderedStr = BS8.unpack rendered+      codeStr = show (statusCode st)+      clHeader = "Content-Length: " ++ show (BS.length body)+  -- Starts with HTTP/1.1+  assert $ BS.isPrefixOf "HTTP/1.1 " rendered+  -- Contains status code+  assert $ clHeader `elem` lines (filter (/= '\r') renderedStr)+         || BS8.pack clHeader `BS.isInfixOf` rendered+  -- Contains status code in status line+  assert $ BS8.pack codeStr `BS.isInfixOf` rendered+  -- Ends with the body bytes+  assert $ BS.isSuffixOf body rendered+++-- | The Content-Length header value in the rendered output matches the+-- body length exactly.+prop_contentLengthAccuracy :: Property+prop_contentLengthAccuracy = property $ do+  st <- forAll genStatus+  hdrs <- forAll genHeaders+  body <- forAll genBody+  let rendered = renderFull st hdrs body+      -- Split on lines to find Content-Length header+      linesList = BS8.lines rendered+      clLines = filter (\l -> BS.isPrefixOf "Content-Length: " l) linesList+  -- There should be exactly one Content-Length header+  assert $ not (null clLines)+  let clLine = case clLines of { (x:_) -> x; [] -> error "unreachable" }+      -- Extract the value after "Content-Length: ", stripping trailing \r+      valBS = BS.drop (BS.length "Content-Length: ") clLine+      valStr = BS8.unpack (stripCR valBS)+  read valStr === BS.length body+  where+    stripCR bs+      | BS.null bs = bs+      | BS.last bs == 0x0d = BS.init bs  -- strip \r+      | otherwise = bs+++-- | renderFull is deterministic: same inputs always produce same output.+prop_renderFullDeterministic :: Property+prop_renderFullDeterministic = property $ do+  st <- forAll genStatus+  hdrs <- forAll genHeaders+  body <- forAll genBody+  renderFull st hdrs body === renderFull st hdrs body+++-- ===================================================================+-- Fuzz: HTTP request parser never crashes on arbitrary input+-- ===================================================================++-- | Feed random bytes to parseRequestHead and assert it returns+-- Maybe (never throws an uncaught exception).+prop_httpParserDoesNotCrash :: Property+prop_httpParserDoesNotCrash = property $ do+  bs <- forAll $ Gen.bytes (Range.linear 0 10000)+  result <- evalIO $ try @SomeException $ case parseRequestHead bs of+    Nothing -> evaluate ()+    Just (rh, rest) ->+      evaluate (BS.length (rhMethod rh)+        `seq` BS.length (rhPath rh)+        `seq` BS.length (rhVersion rh)+        `seq` length (rhHeaders rh)+        `seq` BS.length rest+        `seq` ())+  case result of+    Left _  -> success  -- exception is acceptable (not a crash)+    Right _ -> success+++tests :: IO Bool+tests = checkParallel $$(discover)++main :: IO ()+main = do+  ok <- tests+  if ok then pure () else error "Property tests failed"