diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. 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/spire-http.cabal b/spire-http.cabal new file mode 100644 --- /dev/null +++ b/spire-http.cabal @@ -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 +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 diff --git a/src/Spire/Http.hs b/src/Spire/Http.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Http.hs @@ -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 diff --git a/src/Spire/Http/Compression.hs b/src/Spire/Http/Compression.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Http/Compression.hs @@ -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 + } diff --git a/src/Spire/Http/Cors.hs b/src/Spire/Http/Cors.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Http/Cors.hs @@ -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 + _ -> "" diff --git a/src/Spire/Http/RequestId.hs b/src/Spire/Http/RequestId.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Http/RequestId.hs @@ -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 } diff --git a/src/Spire/Http/SecureHeaders.hs b/src/Spire/Http/SecureHeaders.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Http/SecureHeaders.hs @@ -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 } diff --git a/src/Spire/Http/Static.hs b/src/Spire/Http/Static.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Http/Static.hs @@ -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" diff --git a/src/Spire/Http/Timeout.hs b/src/Spire/Http/Timeout.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Http/Timeout.hs @@ -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") diff --git a/src/Spire/Http/Trace.hs b/src/Spire/Http/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Http/Trace.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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") "SPA" + + 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 == "SPA") + 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."