packages feed

spire-http (empty) → 0.1.0.0

raw patch · 12 files changed

+1174/−0 lines, 12 filesdep +basedep +bytestringdep +directory

Dependencies added: base, bytestring, directory, filepath, http-core, http-types, spire, spire-http, text, zlib

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Revision history for spire-http++## 0.1.0.0 -- 2026-04-27++* Initial release. HTTP-specific middleware layers for spire:+  CORS, secure headers, request IDs, tracing, timeouts, gzip+  compression, and static file serving.
+ 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-http.cabal view
@@ -0,0 +1,76 @@+cabal-version:   3.0+name:            spire-http+version:         0.1.0.0+synopsis:        HTTP-specific middleware layers built on spire+category:        Web+description:+  A collection of HTTP middleware layers using the spire Service/Layer+  abstraction and http-core request/response types. Backend-agnostic;+  works with any server that speaks spire + http-core.++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.Http+    Spire.Http.SecureHeaders+    Spire.Http.RequestId+    Spire.Http.Trace+    Spire.Http.Cors+    Spire.Http.Timeout+    Spire.Http.Compression+    Spire.Http.Static++  build-depends:+      base         >= 4.20 && < 5+    , spire        >= 0.1  && < 0.2+    , http-core    >= 0.1  && < 0.2+    , bytestring   >= 0.11 && < 0.13+    , text         >= 2.0  && < 2.2+    , http-types   >= 0.12 && < 0.13+    , zlib         >= 0.6  && < 0.8+    , directory    >= 1.3  && < 1.4+    , filepath     >= 1.4  && < 1.6++  hs-source-dirs: src+  default-language: GHC2024+  default-extensions:+    OverloadedStrings+    StrictData++  ghc-options: -Wall -funbox-strict-fields++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-http   >= 0.1  && < 0.2+    , spire        >= 0.1  && < 0.2+    , http-core    >= 0.1  && < 0.2+    , bytestring   >= 0.11 && < 0.13+    , http-types   >= 0.12 && < 0.13+    , text         >= 2.0  && < 2.2+    , directory    >= 1.3  && < 1.4+    , filepath     >= 1.4  && < 1.6++source-repository head+  type:     git+  location: https://github.com/joshburgess/acolyte.git
+ src/Spire/Http.hs view
@@ -0,0 +1,49 @@+-- | @spire-http@ — HTTP-specific middleware layers.+--+-- Built on 'spire' and 'http-core'. Backend-agnostic — works with+-- any server that speaks @spire Service IO (Request ByteString) (Response ByteString)@.+module Spire.Http+  ( -- * Security headers+    SecureHeadersConfig (..)+  , defaultSecureHeaders+  , secureHeadersLayer++    -- * Request ID+  , RequestId (..)+  , requestIdLayer+  , requestIdHeader++    -- * Tracing+  , TraceEntry (..)+  , traceLayer++    -- * CORS+  , CorsConfig (..)+  , defaultCors+  , permissiveCors+  , corsLayer++    -- * Timeout+  , timeoutLayer++    -- * Compression+  , CompressionConfig (..)+  , defaultCompression+  , compressionLayer++    -- * Static files+  , StaticConfig (..)+  , defaultStaticConfig+  , staticFilesLayer++    -- * SPA fallback+  , spaFallbackLayer+  ) where++import Spire.Http.SecureHeaders+import Spire.Http.RequestId+import Spire.Http.Trace+import Spire.Http.Cors+import Spire.Http.Timeout+import Spire.Http.Compression+import Spire.Http.Static
+ src/Spire/Http/Compression.hs view
@@ -0,0 +1,77 @@+-- | Response compression middleware.+--+-- Compresses response bodies with gzip when the client sends+-- @Accept-Encoding: gzip@. Skips already-compressed responses+-- and small bodies.+module Spire.Http.Compression+  ( -- * Config+    CompressionConfig (..)+  , defaultCompression+    -- * Layer+  , compressionLayer+  ) where++import Codec.Compression.GZip (compress)+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 Spire (Middleware, middleware)+import Spire.Service (Service (..))+import Http.Core (Request (..), Response (..))+++-- | Compression configuration.+data CompressionConfig = CompressionConfig+  { compMinSize :: !Int+    -- ^ Minimum body size to compress (bytes). Default: 860.+    -- Below this, compression overhead exceeds savings.+  } deriving (Show)++-- | Default compression config: minimum body size of 860 bytes.+defaultCompression :: CompressionConfig+defaultCompression = CompressionConfig+  { compMinSize = 860+  }+++-- | Gzip compression middleware.+compressionLayer :: CompressionConfig -> Middleware IO (Request ByteString) (Response ByteString)+compressionLayer cfg = middleware $ \(Service inner) -> Service $ \req -> do+  resp <- inner req+  if shouldCompress cfg req resp+    then pure (compressResponse resp)+    else pure resp+++shouldCompress :: CompressionConfig -> Request ByteString -> Response ByteString -> Bool+shouldCompress cfg req resp =+  clientAcceptsGzip req+  && BS.length (responseBody resp) >= compMinSize cfg+  && not (isAlreadyCompressed resp)+++clientAcceptsGzip :: Request ByteString -> Bool+clientAcceptsGzip req =+  case lookup "accept-encoding" (requestHeaders req) of+    Just ae -> BS8.isInfixOf "gzip" ae+    Nothing -> False+++isAlreadyCompressed :: Response ByteString -> Bool+isAlreadyCompressed resp =+  case lookup "Content-Encoding" (responseHeaders resp) of+    Just _ -> True+    Nothing -> False+++compressResponse :: Response ByteString -> Response ByteString+compressResponse resp =+  let compressed = LBS.toStrict . compress . LBS.fromStrict $ responseBody resp+      headers = ("Content-Encoding", "gzip")+              : filter (\(k, _) -> k /= "Content-Length") (responseHeaders resp)+  in resp+    { responseBody    = compressed+    , responseHeaders = ("Content-Length", BS8.pack (show (BS.length compressed))) : headers+    }
+ src/Spire/Http/Cors.hs view
@@ -0,0 +1,100 @@+-- | CORS (Cross-Origin Resource Sharing) middleware.+--+-- Handles preflight OPTIONS requests automatically and adds+-- Access-Control-* headers to all responses.+module Spire.Http.Cors+  ( -- * Config+    CorsConfig (..)+  , defaultCors+  , permissiveCors+    -- * Layer+  , corsLayer+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Network.HTTP.Types (status200, status204, Header, ResponseHeaders)++import Spire (Middleware, middleware)+import Spire.Service (Service (..))+import Http.Core (Request (..), Response (..))+++-- | CORS configuration.+data CorsConfig = CorsConfig+  { corsAllowOrigins :: ![ByteString]+    -- ^ Allowed origins. @["*"]@ allows all.+  , corsAllowMethods :: ![ByteString]+    -- ^ Allowed methods for preflight.+  , corsAllowHeaders :: ![ByteString]+    -- ^ Allowed request headers for preflight.+  , corsExposeHeaders :: ![ByteString]+    -- ^ Response headers the browser can access.+  , corsMaxAge :: !(Maybe Int)+    -- ^ Preflight cache duration in seconds.+  , corsAllowCredentials :: !Bool+    -- ^ Allow cookies/auth headers.+  }++-- | Restrictive defaults: no origins allowed.+defaultCors :: CorsConfig+defaultCors = CorsConfig+  { corsAllowOrigins     = []+  , corsAllowMethods     = ["GET", "POST", "PUT", "DELETE", "PATCH"]+  , corsAllowHeaders     = ["Content-Type", "Authorization", "Accept"]+  , corsExposeHeaders    = []+  , corsMaxAge           = Just 86400+  , corsAllowCredentials = False+  }++-- | Allow everything. Good for development.+permissiveCors :: CorsConfig+permissiveCors = defaultCors+  { corsAllowOrigins     = ["*"]+  , corsAllowHeaders     = ["*"]+  , corsAllowCredentials = False+  }+++-- | CORS middleware.+corsLayer :: CorsConfig -> Middleware IO (Request ByteString) (Response ByteString)+corsLayer cfg = middleware $ \(Service inner) -> Service $ \req ->+  if requestMethod req == "OPTIONS"+    then pure (preflightResponse cfg req)+    else do+      resp <- inner req+      pure (addCorsHeaders cfg req resp)+++-- | Build preflight response.+preflightResponse :: CorsConfig -> Request ByteString -> Response ByteString+preflightResponse cfg req = Response status204 hdrs ""+  where+    hdrs = corsHeaders cfg req +++      maybe [] (\age -> [("Access-Control-Max-Age", BS8.pack (show age))]) (corsMaxAge cfg)+++-- | Add CORS headers to a normal response.+addCorsHeaders :: CorsConfig -> Request ByteString -> Response ByteString -> Response ByteString+addCorsHeaders cfg req resp =+  resp { responseHeaders = responseHeaders resp ++ corsHeaders cfg req }+++-- | Common CORS headers.+corsHeaders :: CorsConfig -> Request ByteString -> ResponseHeaders+corsHeaders cfg req =+  [ ("Access-Control-Allow-Origin", origin)+  , ("Access-Control-Allow-Methods", BS8.intercalate ", " (corsAllowMethods cfg))+  , ("Access-Control-Allow-Headers", BS8.intercalate ", " (corsAllowHeaders cfg))+  ] +++  [ ("Access-Control-Expose-Headers", BS8.intercalate ", " (corsExposeHeaders cfg))+  | not (null (corsExposeHeaders cfg)) ] +++  [ ("Access-Control-Allow-Credentials", "true")+  | corsAllowCredentials cfg ]+  where+    origin+      | corsAllowOrigins cfg == ["*"] = "*"+      | otherwise = case lookup "origin" (requestHeaders req) of+          Just o | o `elem` corsAllowOrigins cfg -> o+          _ -> ""
+ src/Spire/Http/RequestId.hs view
@@ -0,0 +1,78 @@+-- | Request ID middleware.+--+-- Generates a unique request ID for each request (or preserves an+-- existing one from the @X-Request-Id@ header). The ID is:+--+-- 1. Stored in request 'Extensions' (accessible to handlers)+-- 2. Copied to the response @X-Request-Id@ header+--+-- @+-- svc |> requestIdLayer+-- @+module Spire.Http.RequestId+  ( -- * Request ID type+    RequestId (..)+    -- * Layer+  , requestIdLayer+    -- * Header name+  , requestIdHeader+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.IORef+import Data.List (lookup)+import Network.HTTP.Types (HeaderName)++import Spire (Middleware, middleware)+import Spire.Service (Service (..))+import Http.Core+  ( Request (..), Response (..)+  , Extensions, insertExtension+  )+++-- | A request identifier, either propagated from the client or generated.+newtype RequestId = RequestId { unRequestId :: ByteString }+  deriving (Eq, Ord, Show)+++-- | The header name used for request IDs.+requestIdHeader :: HeaderName+requestIdHeader = "X-Request-Id"+++-- | Simple counter-based ID generator (sufficient for single-process).+-- In production you'd use UUID v4 or similar.+newtype IdGen = IdGen (IORef Int)++newIdGen :: IO IdGen+newIdGen = IdGen <$> newIORef 0++nextId :: IdGen -> IO ByteString+nextId (IdGen ref) = do+  n <- atomicModifyIORef' ref (\n -> (n + 1, n))+  pure $ BS.pack $ "req-" ++ show n+++-- | Middleware that assigns and propagates request IDs.+requestIdLayer :: IO (Middleware IO (Request ByteString) (Response ByteString))+requestIdLayer = do+  gen <- newIdGen+  pure $ middleware $ \(Service inner) -> Service $ \req -> do+    -- Use existing header or generate new+    let existing = lookup requestIdHeader (requestHeaders req)+    rid <- case existing of+      Just val -> pure val+      Nothing  -> nextId gen++    -- Store in extensions for handler access+    let reqId = RequestId rid+    insertExtension reqId (requestExtensions req)++    -- Call inner service+    resp <- inner req++    -- Add to response headers+    pure resp+      { responseHeaders = (requestIdHeader, rid) : responseHeaders resp }
+ src/Spire/Http/SecureHeaders.hs view
@@ -0,0 +1,85 @@+-- | OWASP-recommended security headers middleware.+--+-- Adds security headers to every response. Configurable via record+-- update on 'SecureHeadersConfig'.+--+-- Default headers:+--+-- * @X-Content-Type-Options: nosniff@+-- * @X-Frame-Options: DENY@+-- * @X-XSS-Protection: 0@ (modern browsers don't need it; can cause issues)+-- * @Referrer-Policy: strict-origin-when-cross-origin@+-- * @Content-Security-Policy: default-src 'self'@+-- * @Permissions-Policy: camera=(), microphone=(), geolocation=()@+--+-- Optional: @Strict-Transport-Security@ (HSTS) — off by default since+-- it requires HTTPS.+module Spire.Http.SecureHeaders+  ( -- * Config+    SecureHeadersConfig (..)+  , defaultSecureHeaders+    -- * Layer+  , secureHeadersLayer+  ) where++import Data.ByteString (ByteString)+import Network.HTTP.Types (ResponseHeaders, Header)++import Spire (Middleware, middleware)+import Spire.Service (Service (..), mapResponse)+import Http.Core (Request, Response (..))+++-- | Configuration for security headers.+data SecureHeadersConfig = SecureHeadersConfig+  { xContentTypeOptions :: !ByteString+  , xFrameOptions       :: !ByteString+  , xXssProtection      :: !ByteString+  , referrerPolicy      :: !ByteString+  , contentSecurityPolicy :: !ByteString+  , permissionsPolicy   :: !ByteString+  , strictTransportSecurity :: !(Maybe ByteString)+    -- ^ @Nothing@ = don't add HSTS. @Just "max-age=63072000"@ for 2 years.+  }+++-- | Sensible defaults matching OWASP recommendations.+defaultSecureHeaders :: SecureHeadersConfig+defaultSecureHeaders = SecureHeadersConfig+  { xContentTypeOptions     = "nosniff"+  , xFrameOptions           = "DENY"+  , xXssProtection          = "0"+  , referrerPolicy          = "strict-origin-when-cross-origin"+  , contentSecurityPolicy   = "default-src 'self'"+  , permissionsPolicy       = "camera=(), microphone=(), geolocation=()"+  , strictTransportSecurity = Nothing+  }+++-- | Build the header list from config.+configHeaders :: SecureHeadersConfig -> ResponseHeaders+configHeaders cfg = base ++ hsts+  where+    base =+      [ ("X-Content-Type-Options",  xContentTypeOptions cfg)+      , ("X-Frame-Options",         xFrameOptions cfg)+      , ("X-XSS-Protection",        xXssProtection cfg)+      , ("Referrer-Policy",         referrerPolicy cfg)+      , ("Content-Security-Policy", contentSecurityPolicy cfg)+      , ("Permissions-Policy",      permissionsPolicy cfg)+      ]+    hsts = case strictTransportSecurity cfg of+      Nothing  -> []+      Just val -> [("Strict-Transport-Security", val)]+++-- | Middleware that adds security headers to every response.+secureHeadersLayer+  :: SecureHeadersConfig+  -> Middleware IO (Request ByteString) (Response ByteString)+secureHeadersLayer cfg = middleware $ \inner ->+  mapResponse addHeaders inner+  where+    hdrs = configHeaders cfg+    addHeaders resp = resp+      { responseHeaders = responseHeaders resp ++ hdrs }
+ src/Spire/Http/Static.hs view
@@ -0,0 +1,180 @@+-- | Static file serving and SPA fallback middleware.+--+-- Serves files from a directory when the request path matches a prefix.+-- Includes MIME type detection and directory traversal prevention.+--+-- For single-page applications, the SPA fallback layer serves @index.html@+-- when the inner service returns 404 for paths that don't look like files.+module Spire.Http.Static+  ( -- * Static file serving+    staticFilesLayer+  , StaticConfig (..)+  , defaultStaticConfig+    -- * SPA fallback+  , spaFallbackLayer+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types (statusCode, mkStatus)+import System.Directory (canonicalizePath, doesFileExist, getFileSize)+import System.FilePath ((</>), takeExtension)+import Data.List (isPrefixOf)++import Spire (Middleware, middleware)+import Spire.Service (Service (..))+import Http.Core (Request (..), Response (..), ok, badRequest)+++-- | Configuration for static file serving.+data StaticConfig = StaticConfig+  { staticPrefix :: !Text+    -- ^ URL prefix to match (e.g. @"/static"@).+  , staticDir    :: !FilePath+    -- ^ Directory to serve files from.+  } deriving (Show)+++-- | Construct a 'StaticConfig' with the given prefix and directory.+defaultStaticConfig :: Text -> FilePath -> StaticConfig+defaultStaticConfig = StaticConfig+++-- | Middleware that serves files from a directory for paths matching a prefix.+--+-- If the request path starts with the configured prefix, the layer strips the+-- prefix and maps the remainder to a filesystem path under the configured+-- directory. If the file exists, it is served with an appropriate Content-Type+-- header. If the file does not exist, the request passes through to the inner+-- service.+--+-- Directory traversal is prevented by rejecting any path containing @".."@.+staticFilesLayer :: StaticConfig -> Middleware IO (Request ByteString) (Response ByteString)+staticFilesLayer cfg = middleware $ \(Service inner) -> Service $ \req -> do+  let rawPath = TE.decodeUtf8Lenient (requestPathRaw req)+      prefix  = normalizePrefix (staticPrefix cfg)+  if T.isPrefixOf prefix rawPath+    then do+      let relPath = T.unpack (T.drop (T.length prefix) rawPath)+      if hasTraversal relPath+        then pure (badRequest [] "Invalid path")+        else do+          let filePath = staticDir cfg </> relPath+          -- Canonicalize both paths to resolve symlinks and ".." segments+          -- that might bypass the traversal check above.+          canonPath <- canonicalizePath filePath+          canonDir  <- canonicalizePath (staticDir cfg)+          if canonDir `isPrefixOf` canonPath+            then do+              exists <- doesFileExist canonPath+              if exists+                then serveFile canonPath+                else inner req+            else pure (badRequest [] "Invalid path")+    else inner req+++-- | SPA fallback middleware.+--+-- If the inner service returns a 404 response and the request path does not+-- look like a file request (i.e. has no file extension) and does not start+-- with @"/api"@, serve @index.html@ from the given directory instead.+spaFallbackLayer :: FilePath -> Middleware IO (Request ByteString) (Response ByteString)+spaFallbackLayer dir = middleware $ \(Service inner) -> Service $ \req -> do+  resp <- inner req+  if statusCode (responseStatus resp) == 404 && isSpaRoute req+    then do+      let indexPath = dir </> "index.html"+      exists <- doesFileExist indexPath+      if exists+        then serveFile indexPath+        else pure resp+    else pure resp+++-- ===================================================================+-- Internal helpers+-- ===================================================================++-- | Ensure the prefix ends with a slash for clean stripping.+normalizePrefix :: Text -> Text+normalizePrefix p+  | T.null p         = "/"+  | T.last p == '/'  = p+  | otherwise        = p <> "/"++-- | Check for directory traversal attempts.+hasTraversal :: String -> Bool+hasTraversal path = ".." `elem` splitPath path+  where+    splitPath = filter (not . null) . foldr go [[]]+    go '/' acc       = [] : acc+    go c   (x : xs)  = (c : x) : xs+    go _   []        = []++-- | Determine if a request path looks like a SPA route (not a file, not /api).+isSpaRoute :: Request ByteString -> Bool+isSpaRoute req =+  let rawPath = requestPathRaw req+  in not (hasFileExtension rawPath) && not (BS.isPrefixOf "/api" rawPath)++-- | Check if a path has a file extension.+-- Only examines the last path segment. Dotfiles (e.g. @.hidden@, @.env@)+-- are not considered to have a file extension — the dot must not be the+-- first character.+hasFileExtension :: ByteString -> Bool+hasFileExtension path =+  let segments = filter (not . BS.null) $ BS.split 0x2F path  -- split on '/'+  in case segments of+    [] -> False+    _  -> let lastSeg = last segments+              dotIdx = BS8.elemIndex '.' lastSeg+          in case dotIdx of+               Nothing -> False+               Just 0  -> False  -- dotfile like .hidden, not a file extension+               Just _  -> True++-- | Maximum file size for static file serving (50 MiB).+-- Files larger than this are rejected with 413 Payload Too Large+-- to avoid loading excessive data into memory.+maxStaticFileSize :: Integer+maxStaticFileSize = 50 * 1024 * 1024++-- | Serve a file from disk with appropriate Content-Type.+-- Rejects files larger than 'maxStaticFileSize' with 413.+serveFile :: FilePath -> IO (Response ByteString)+serveFile filePath = do+  size <- getFileSize filePath+  if size > maxStaticFileSize+    then pure (Response (mkStatus 413 "Payload Too Large") [] "File too large")+    else do+      contents <- BS.readFile filePath+      let ext  = drop 1 (takeExtension filePath)  -- drop the leading '.'+          mime = mimeType ext+      pure (ok [("Content-Type", mime)] contents)+++-- | Map file extensions to MIME types.+mimeType :: String -> ByteString+mimeType ext = case ext of+  "html"  -> "text/html"+  "css"   -> "text/css"+  "js"    -> "application/javascript"+  "json"  -> "application/json"+  "png"   -> "image/png"+  "jpg"   -> "image/jpeg"+  "jpeg"  -> "image/jpeg"+  "gif"   -> "image/gif"+  "svg"   -> "image/svg+xml"+  "ico"   -> "image/x-icon"+  "woff"  -> "font/woff"+  "woff2" -> "font/woff2"+  "ttf"   -> "font/ttf"+  "txt"   -> "text/plain"+  "xml"   -> "application/xml"+  "pdf"   -> "application/pdf"+  _       -> "application/octet-stream"
+ src/Spire/Http/Timeout.hs view
@@ -0,0 +1,44 @@+-- | Request timeout middleware.+--+-- Kills the handler if it takes longer than the configured duration+-- and returns 408 Request Timeout.+module Spire.Http.Timeout+  ( timeoutLayer+  ) where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.MVar+import Data.ByteString (ByteString)+import Network.HTTP.Types (status408)++import Spire (Middleware, middleware)+import Spire.Service (Service (..))+import Http.Core (Request, Response (..))+++-- | Middleware that enforces a request timeout.+--+-- @+-- svc |> timeoutLayer 5000000  -- 5 second timeout+-- @+timeoutLayer :: Int  -- ^ Timeout in microseconds+             -> Middleware IO (Request ByteString) (Response ByteString)+timeoutLayer usec = middleware $ \(Service inner) -> Service $ \req -> do+  resultVar <- newEmptyMVar++  -- Run the handler in a thread+  tid <- forkIO $ do+    resp <- inner req+    putMVar resultVar (Just resp)++  -- Run the timeout in another thread+  _ <- forkIO $ do+    threadDelay usec+    putMVar resultVar Nothing++  result <- takeMVar resultVar+  case result of+    Just resp -> pure resp+    Nothing -> do+      killThread tid+      pure (Response status408 [("Content-Type", "text/plain")] "Request Timeout")
+ src/Spire/Http/Trace.hs view
@@ -0,0 +1,50 @@+-- | Request/response tracing middleware.+--+-- Logs request method, path, response status, and elapsed time via+-- a user-provided callback. This avoids a hard dependency on any+-- specific logging framework.+--+-- @+-- svc |> traceLayer (\\entry -> putStrLn (show entry))+-- @+module Spire.Http.Trace+  ( -- * Trace entry+    TraceEntry (..)+    -- * Layer+  , traceLayer+  ) where++import Data.ByteString (ByteString)+import Network.HTTP.Types (Method, Status, statusCode)+import Data.IORef+import System.IO (hFlush, stdout)++import Spire (Middleware, middleware)+import Spire.Service (Service (..))+import Http.Core (Request (..), Response (..))+++-- | Information recorded for each request/response pair.+data TraceEntry = TraceEntry+  { traceMethod :: !Method+  , tracePath   :: !ByteString+  , traceStatus :: !Int+  } deriving (Show, Eq)+++-- | Middleware that traces each request/response.+--+-- The callback receives a 'TraceEntry' after each request completes.+-- Keep the callback fast — it runs in the request path.+traceLayer+  :: (TraceEntry -> IO ())+  -> Middleware IO (Request ByteString) (Response ByteString)+traceLayer onTrace = middleware $ \(Service inner) -> Service $ \req -> do+  resp <- inner req+  let entry = TraceEntry+        { traceMethod = requestMethod req+        , tracePath   = requestPathRaw req+        , traceStatus = statusCode (responseStatus resp)+        }+  onTrace entry+  pure resp
+ test/Main.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Control.Concurrent (threadDelay)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.IORef+import Data.List (lookup)+import Network.HTTP.Types (status200, status204, status404, status408, methodGet, methodPost, statusCode)+import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, getTemporaryDirectory)+import System.FilePath ((</>))++import Spire+import Spire.Http+import Http.Core+++assert :: String -> Bool -> IO ()+assert label True  = putStrLn $ "  OK: " ++ label+assert label False = error   $ "FAIL: " ++ label+++-- | Make a simple test service that returns 200 with "ok".+echoService :: Service IO (Request ByteString) (Response ByteString)+echoService = Service $ \_ -> pure (ok [] "ok")+++-- | Make a test request.+mkReq :: ByteString -> ByteString -> IO (Request ByteString)+mkReq method path = do+  exts <- emptyExtensions+  pure Request+    { requestMethod     = method+    , requestPathRaw    = path+    , requestPath       = []+    , requestQuery      = []+    , requestHeaders    = []+    , requestBody       = ""+    , requestExtensions = exts+    }+++-- ===================================================================+-- SecureHeaders tests+-- ===================================================================++testSecureHeaders :: IO ()+testSecureHeaders = do+  let svc = echoService |> secureHeadersLayer defaultSecureHeaders+  req <- mkReq methodGet "/test"+  resp <- runService svc req++  let hdrs = responseHeaders resp+  assert "adds X-Content-Type-Options" (lookup "X-Content-Type-Options" hdrs == Just "nosniff")+  assert "adds X-Frame-Options" (lookup "X-Frame-Options" hdrs == Just "DENY")+  assert "adds Referrer-Policy" (lookup "Referrer-Policy" hdrs == Just "strict-origin-when-cross-origin")+  assert "adds CSP" (lookup "Content-Security-Policy" hdrs == Just "default-src 'self'")+  assert "no HSTS by default" (lookup "Strict-Transport-Security" hdrs == Nothing)++  -- With HSTS enabled+  let cfg = defaultSecureHeaders { strictTransportSecurity = Just "max-age=63072000" }+      svc2 = echoService |> secureHeadersLayer cfg+  resp2 <- runService svc2 req+  let hdrs2 = responseHeaders resp2+  assert "HSTS when configured" (lookup "Strict-Transport-Security" hdrs2 == Just "max-age=63072000")+++-- ===================================================================+-- RequestId tests+-- ===================================================================++testRequestId :: IO ()+testRequestId = do+  ridLayer <- requestIdLayer+  let svc = echoService |> ridLayer+  req <- mkReq methodGet "/test"++  -- First request gets an ID+  resp1 <- runService svc req+  let hdrs1 = responseHeaders resp1+  assert "adds X-Request-Id header" (lookup "X-Request-Id" hdrs1 /= Nothing)++  -- Second request gets a different ID+  req2 <- mkReq methodGet "/test2"+  resp2 <- runService svc req2+  let rid1 = lookup "X-Request-Id" (responseHeaders resp1)+      rid2 = lookup "X-Request-Id" (responseHeaders resp2)+  assert "sequential IDs differ" (rid1 /= rid2)++  -- Existing X-Request-Id is preserved+  exts <- emptyExtensions+  let req3 = Request+        { requestMethod = methodGet+        , requestPathRaw = "/test3"+        , requestPath = []+        , requestQuery = []+        , requestHeaders = [("X-Request-Id", "custom-123")]+        , requestBody = ""+        , requestExtensions = exts+        }+  resp3 <- runService svc req3+  assert "preserves existing ID" (lookup "X-Request-Id" (responseHeaders resp3) == Just "custom-123")++  -- RequestId stored in extensions+  exts4 <- emptyExtensions+  let checkExtSvc = Service $ \req -> do+        mRid <- lookupExtension @RequestId (requestExtensions req)+        case mRid of+          Just (RequestId rid) -> pure (ok [] rid)+          Nothing              -> pure (ok [] "no-id")+      svc4 = checkExtSvc |> ridLayer+      req4 = Request+        { requestMethod = methodGet+        , requestPathRaw = "/ext"+        , requestPath = []+        , requestQuery = []+        , requestHeaders = []+        , requestBody = ""+        , requestExtensions = exts4+        }+  resp4 <- runService svc4 req4+  assert "RequestId in extensions" (responseBody resp4 /= "no-id")+++-- ===================================================================+-- Trace tests+-- ===================================================================++testTrace :: IO ()+testTrace = do+  ref <- newIORef ([] :: [TraceEntry])+  let svc = echoService |> traceLayer (\e -> modifyIORef' ref (++ [e]))+  req <- mkReq methodPost "/users"++  _ <- runService svc req+  entries <- readIORef ref++  assert "trace captures one entry" (length entries == 1)+  let e = head entries+  assert "trace: method" (traceMethod e == methodPost)+  assert "trace: path" (tracePath e == "/users")+  assert "trace: status 200" (traceStatus e == 200)+++-- ===================================================================+-- Composition test: all three layers stacked+-- ===================================================================++testComposition :: IO ()+testComposition = do+  ref <- newIORef ([] :: [TraceEntry])+  ridLayer <- requestIdLayer+  let svc = echoService+            |> ridLayer+            |> traceLayer (\e -> modifyIORef' ref (++ [e]))+            |> secureHeadersLayer defaultSecureHeaders+  req <- mkReq methodGet "/health"+  resp <- runService svc req++  let hdrs = responseHeaders resp+  assert "composed: has security headers" (lookup "X-Frame-Options" hdrs == Just "DENY")+  assert "composed: has request ID" (lookup "X-Request-Id" hdrs /= Nothing)++  entries <- readIORef ref+  assert "composed: trace fired" (length entries == 1)+++-- ===================================================================+-- CORS tests+-- ===================================================================++testCors :: IO ()+testCors = do+  let svc = echoService |> corsLayer permissiveCors++  -- Preflight OPTIONS -> 204 with CORS headers+  exts1 <- emptyExtensions+  let optReq = Request+        { requestMethod = "OPTIONS"+        , requestPathRaw = "/test"+        , requestPath = ["test"]+        , requestQuery = []+        , requestHeaders = [("origin", "http://example.com")]+        , requestBody = ""+        , requestExtensions = exts1+        }+  resp1 <- runService svc optReq+  assert "CORS: preflight 204" (statusCode (responseStatus resp1) == 204)+  assert "CORS: Allow-Origin on preflight" (lookup "Access-Control-Allow-Origin" (responseHeaders resp1) == Just "*")+  assert "CORS: Allow-Methods on preflight" (lookup "Access-Control-Allow-Methods" (responseHeaders resp1) /= Nothing)++  -- Normal GET -> 200 with CORS headers added+  req2 <- mkReq methodGet "/test"+  resp2 <- runService svc req2+  assert "CORS: normal 200" (statusCode (responseStatus resp2) == 200)+  assert "CORS: Allow-Origin on GET" (lookup "Access-Control-Allow-Origin" (responseHeaders resp2) == Just "*")+++-- ===================================================================+-- Compression tests+-- ===================================================================++testCompression :: IO ()+testCompression = do+  -- Big body service (above min threshold)+  let bigBody = BS.replicate 2000 65  -- 2000 'A's+      bigSvc = Service $ \_ -> pure (ok [("Content-Type", "text/plain")] bigBody)+      svc = bigSvc |> compressionLayer defaultCompression++  -- With Accept-Encoding: gzip+  exts1 <- emptyExtensions+  let req1 = Request+        { requestMethod = "GET"+        , requestPathRaw = "/big"+        , requestPath = ["big"]+        , requestQuery = []+        , requestHeaders = [("accept-encoding", "gzip, deflate")]+        , requestBody = ""+        , requestExtensions = exts1+        }+  resp1 <- runService svc req1+  assert "compression: Content-Encoding gzip" (lookup "Content-Encoding" (responseHeaders resp1) == Just "gzip")+  assert "compression: body smaller" (BS.length (responseBody resp1) < 2000)++  -- Without Accept-Encoding -> no compression+  req2 <- mkReq methodGet "/big"+  resp2 <- runService svc req2+  assert "compression: no encoding without header" (lookup "Content-Encoding" (responseHeaders resp2) == Nothing)+  assert "compression: body unchanged" (BS.length (responseBody resp2) == 2000)++  -- Small body -> skip compression+  let smallSvc = echoService |> compressionLayer defaultCompression+  exts3 <- emptyExtensions+  let req3 = Request+        { requestMethod = "GET"+        , requestPathRaw = "/small"+        , requestPath = ["small"]+        , requestQuery = []+        , requestHeaders = [("accept-encoding", "gzip")]+        , requestBody = ""+        , requestExtensions = exts3+        }+  resp3 <- runService smallSvc req3+  assert "compression: skip small body" (lookup "Content-Encoding" (responseHeaders resp3) == Nothing)+++-- ===================================================================+-- Timeout tests+-- ===================================================================++testTimeout :: IO ()+testTimeout = do+  -- Fast handler: completes within timeout+  let fastSvc :: Service IO (Request ByteString) (Response ByteString)+      fastSvc = Service $ \_ -> pure (ok [] "fast")+      svc1 = fastSvc |> timeoutLayer 1000000  -- 1 second+  req1 <- mkReq methodGet "/fast"+  resp1 <- runService svc1 req1+  assert "timeout: fast handler succeeds" (statusCode (responseStatus resp1) == 200)+  assert "timeout: fast body" (responseBody resp1 == "fast")++  -- Slow handler: exceeds timeout+  let slowSvc :: Service IO (Request ByteString) (Response ByteString)+      slowSvc = Service $ \_ -> do+        threadDelay 2000000  -- 2 seconds+        pure (ok [] "slow")+      svc2 = slowSvc |> timeoutLayer 200000  -- 200ms timeout+  req2 <- mkReq methodGet "/slow"+  resp2 <- runService svc2 req2+  assert "timeout: slow handler -> 408" (statusCode (responseStatus resp2) == 408)+++-- ===================================================================+-- Static file serving tests+-- ===================================================================++-- | A 404 inner service for static file tests.+notFoundService :: Service IO (Request ByteString) (Response ByteString)+notFoundService = Service $ \_ -> pure (notFound [] "not found")++testStaticFiles :: IO ()+testStaticFiles = do+  -- Set up temp directory with a test file+  tmpBase <- getTemporaryDirectory+  let tmpDir = tmpBase </> "spire-http-static-test"+  createDirectoryIfMissing True tmpDir+  BS.writeFile (tmpDir </> "test.txt") "hello static"+  BS.writeFile (tmpDir </> "style.css") "body{}"++  let cfg = defaultStaticConfig "/static" tmpDir+      svc = notFoundService |> staticFilesLayer cfg++  -- Serve existing file with correct content-type+  req1 <- mkReq methodGet "/static/test.txt"+  resp1 <- runService svc req1+  assert "static: serves existing file" (statusCode (responseStatus resp1) == 200)+  assert "static: correct body" (responseBody resp1 == "hello static")+  assert "static: text/plain content-type" (lookup "Content-Type" (responseHeaders resp1) == Just "text/plain")++  -- Serve CSS with correct content-type+  req2 <- mkReq methodGet "/static/style.css"+  resp2 <- runService svc req2+  assert "static: CSS content-type" (lookup "Content-Type" (responseHeaders resp2) == Just "text/css")++  -- Non-existent file falls through to inner service+  req3 <- mkReq methodGet "/static/nonexistent.txt"+  resp3 <- runService svc req3+  assert "static: nonexistent falls through" (statusCode (responseStatus resp3) == 404)++  -- Directory traversal is rejected+  req4 <- mkReq methodGet "/static/../etc/passwd"+  resp4 <- runService svc req4+  assert "static: traversal rejected" (statusCode (responseStatus resp4) == 400)++  -- Non-matching prefix falls through+  req5 <- mkReq methodGet "/other/test.txt"+  resp5 <- runService svc req5+  assert "static: non-matching prefix falls through" (statusCode (responseStatus resp5) == 404)++  -- Cleanup+  removeDirectoryRecursive tmpDir+++-- ===================================================================+-- SPA fallback tests+-- ===================================================================++testSpaFallback :: IO ()+testSpaFallback = do+  -- Set up temp directory with index.html+  tmpBase <- getTemporaryDirectory+  let tmpDir = tmpBase </> "spire-http-spa-test"+  createDirectoryIfMissing True tmpDir+  BS.writeFile (tmpDir </> "index.html") "<html>SPA</html>"++  let svc = notFoundService |> spaFallbackLayer tmpDir++  -- SPA route (no extension, not /api) -> serve index.html+  req1 <- mkReq methodGet "/dashboard"+  resp1 <- runService svc req1+  assert "spa: fallback serves index.html" (statusCode (responseStatus resp1) == 200)+  assert "spa: correct body" (responseBody resp1 == "<html>SPA</html>")+  assert "spa: html content-type" (lookup "Content-Type" (responseHeaders resp1) == Just "text/html")++  -- File-like path (has extension) -> no fallback+  req2 <- mkReq methodGet "/bundle.js"+  resp2 <- runService svc req2+  assert "spa: file path not intercepted" (statusCode (responseStatus resp2) == 404)++  -- API path -> no fallback+  req3 <- mkReq methodGet "/api/users"+  resp3 <- runService svc req3+  assert "spa: API path not intercepted" (statusCode (responseStatus resp3) == 404)++  -- Inner service returns 200 -> no fallback+  let okSvc = echoService |> spaFallbackLayer tmpDir+  req4 <- mkReq methodGet "/dashboard"+  resp4 <- runService okSvc req4+  assert "spa: 200 passes through" (statusCode (responseStatus resp4) == 200)+  assert "spa: 200 body unchanged" (responseBody resp4 == "ok")++  -- Cleanup+  removeDirectoryRecursive tmpDir+++-- ===================================================================+-- Main+-- ===================================================================++main :: IO ()+main = do+  putStrLn "spire-http tests:"+  putStrLn ""+  putStrLn "SecureHeaders:"+  testSecureHeaders+  putStrLn ""+  putStrLn "RequestId:"+  testRequestId+  putStrLn ""+  putStrLn "Trace:"+  testTrace+  putStrLn ""+  putStrLn "Composition:"+  testComposition+  putStrLn ""+  putStrLn "CORS:"+  testCors+  putStrLn ""+  putStrLn "Compression:"+  testCompression+  putStrLn ""+  putStrLn "Timeout:"+  testTimeout+  putStrLn ""+  putStrLn "Static files:"+  testStaticFiles+  putStrLn ""+  putStrLn "SPA fallback:"+  testSpaFallback+  putStrLn ""+  putStrLn "All spire-http tests passed."