packages feed

spire-wai (empty) → 0.1.0.0

raw patch · 5 files changed

+414/−0 lines, 5 filesdep +basedep +bytestringdep +http-core

Dependencies added: base, bytestring, http-core, http-types, spire, spire-http, spire-wai, text, wai, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Revision history for spire-wai++## 0.1.0.0 -- 2026-04-27++* Initial release. Wai/warp adapter for spire Service values: turns a+  Service into a wai Application so it can run on the standard+  Haskell HTTP stack.
+ 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-wai.cabal view
@@ -0,0 +1,68 @@+cabal-version:   3.0+name:            spire-wai+version:         0.1.0.0+synopsis:        WAI/warp backend adapter for spire+category:        Web+description:+  Bridges spire Services (using http-core types) to WAI Applications+  running on warp. This is the only package that imports WAI; everything+  above is backend-agnostic.++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.Wai++  build-depends:+      base         >= 4.20 && < 5+    , spire        >= 0.1  && < 0.2+    , http-core    >= 0.1  && < 0.2+    , wai          >= 3.2  && < 3.3+    , warp         >= 3.3  && < 3.5+    , bytestring   >= 0.11 && < 0.13+    , text         >= 2.0  && < 2.2+    , http-types   >= 0.12 && < 0.13++  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-wai    >= 0.1  && < 0.2+    , spire        >= 0.1  && < 0.2+    , spire-http   >= 0.1  && < 0.2+    , http-core    >= 0.1  && < 0.2+    , wai          >= 3.2  && < 3.3+    , warp         >= 3.3  && < 3.5+    , bytestring   >= 0.11 && < 0.13+    , http-types   >= 0.12 && < 0.13++source-repository head+  type:     git+  location: https://github.com/joshburgess/acolyte.git
+ src/Spire/Wai.hs view
@@ -0,0 +1,150 @@+-- | WAI/warp backend adapter for spire.+--+-- This is the __only package that imports WAI__. Everything above+-- (spire, spire-http, acolyte-server) uses http-core types+-- and is backend-agnostic.+--+-- @+-- import Spire.Wai (runWarp)+-- runWarp 3000 myService+-- @+module Spire.Wai+  ( -- * Running on warp+    runWarp+  , runWarpSettings++    -- * Core WAI conversion+  , toWaiApp+  , fromWaiRequest+  , toWaiResponse++    -- * WAI middleware interop (migration bridge)+  , fromWaiMiddleware+  ) where++import Control.Concurrent.MVar+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Text (Text)++import qualified Network.Wai as Wai+import qualified Network.Wai.Internal as Wai (ResponseReceived (..))+import qualified Network.Wai.Handler.Warp as Warp++import Spire (Middleware, middleware)+import Spire.Service (Service (..))+import Spire.Layer (Layer (..))+import Http.Core+  ( Request (..), Response (..)+  , emptyExtensions+  )+++-- ===================================================================+-- Running on warp+-- ===================================================================++-- | Run a spire Service on warp at the given port.+runWarp :: Int -> Service IO (Request ByteString) (Response ByteString) -> IO ()+runWarp port svc = Warp.run port (toWaiApp svc)++-- | Run with full warp settings.+runWarpSettings+  :: Warp.Settings+  -> Service IO (Request ByteString) (Response ByteString)+  -> IO ()+runWarpSettings settings svc = Warp.runSettings settings (toWaiApp svc)+++-- ===================================================================+-- Core WAI conversion+-- ===================================================================++-- | Convert a spire Service to a WAI Application.+toWaiApp :: Service IO (Request ByteString) (Response ByteString) -> Wai.Application+toWaiApp (Service f) waiReq respond = do+  req <- fromWaiRequest waiReq+  resp <- f req+  respond (toWaiResponse resp)++-- | Convert a WAI Request to our Request (collects body as strict bytes).+fromWaiRequest :: Wai.Request -> IO (Request ByteString)+fromWaiRequest waiReq = do+  body <- LBS.toStrict <$> Wai.consumeRequestBodyStrict waiReq+  exts <- emptyExtensions+  pure Request+    { requestMethod     = Wai.requestMethod waiReq+    , requestPathRaw    = Wai.rawPathInfo waiReq+    , requestPath       = filter (/= "") (Wai.pathInfo waiReq)+    , requestQuery      = Wai.queryString waiReq+    , requestHeaders    = Wai.requestHeaders waiReq+    , requestBody       = body+    , requestExtensions = exts+    }++-- | Convert our Response to a WAI Response.+toWaiResponse :: Response ByteString -> Wai.Response+toWaiResponse resp =+  Wai.responseLBS+    (responseStatus resp)+    (responseHeaders resp)+    (LBS.fromStrict (responseBody resp))+++-- ===================================================================+-- WAI middleware interop+-- ===================================================================++-- | Wrap existing WAI Middleware as a spire Middleware.+--+-- Migration bridge for @wai-extra@, @wai-cors@, etc. The WAI+-- middleware wraps the service at the WAI level.+--+-- @+-- import qualified Network.Wai.Middleware.Gzip as Wai+-- myService |> fromWaiMiddleware Wai.gzip+-- @+fromWaiMiddleware+  :: Wai.Middleware+  -> Middleware IO (Request ByteString) (Response ByteString)+fromWaiMiddleware waiMw = middleware $ \innerSvc ->+  let innerWaiApp = toWaiApp innerSvc+      wrappedWaiApp = waiMw innerWaiApp+  in  waiAppToService wrappedWaiApp+++-- | Convert a WAI Application to a spire Service.+-- Bridges WAI's CPS response style via MVar.+waiAppToService :: Wai.Application -> Service IO (Request ByteString) (Response ByteString)+waiAppToService waiApp = Service $ \req -> do+  let waiReq = toWaiRequest req+  resultVar <- newEmptyMVar+  _ <- waiApp waiReq $ \waiResp -> do+    putMVar resultVar (fromWaiResponse waiResp)+    pure Wai.ResponseReceived+  takeMVar resultVar+++-- | Reconstruct a minimal WAI Request from our Request.+-- Lossy — vault, socket info, HTTP version not preserved.+toWaiRequest :: Request ByteString -> Wai.Request+toWaiRequest req = Wai.defaultRequest+  { Wai.requestMethod     = requestMethod req+  , Wai.rawPathInfo       = requestPathRaw req+  , Wai.pathInfo          = requestPath req+  , Wai.queryString       = requestQuery req+  , Wai.requestHeaders    = requestHeaders req+  , Wai.requestBodyLength = Wai.KnownLength (fromIntegral $ BS.length $ requestBody req)+  }+++-- | Extract status and headers from a WAI Response.+-- Body is empty — for header-only middleware (CORS, security headers)+-- the real body passes through the inner toWaiApp/toWaiResponse path.+fromWaiResponse :: Wai.Response -> Response ByteString+fromWaiResponse waiResp = Response+  { responseStatus  = Wai.responseStatus waiResp+  , responseHeaders = Wai.responseHeaders waiResp+  , responseBody    = ""+  }
+ test/Main.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Control.Concurrent.MVar+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.List (lookup)+import Network.HTTP.Types++import qualified Network.Wai as Wai+import qualified Network.Wai.Internal as Wai (ResponseReceived (..))++import Spire+import Spire.Http (secureHeadersLayer, defaultSecureHeaders)+import Spire.Wai+import Http.Core+++assert :: String -> Bool -> IO ()+assert label True  = putStrLn $ "  OK: " ++ label+assert label False = error   $ "FAIL: " ++ label+++-- ===================================================================+-- toWaiApp / fromWaiRequest / toWaiResponse+-- ===================================================================++testToWaiApp :: IO ()+testToWaiApp = do+  let svc :: Service IO (Request ByteString) (Response ByteString)+      svc = Service $ \req -> do+        let body = requestMethod req <> " " <> requestPathRaw req+        pure (ok [("Content-Type", "text/plain")] body)++  let waiApp = toWaiApp svc++  let waiReq = Wai.defaultRequest+        { Wai.requestMethod = methodGet+        , Wai.rawPathInfo   = "/hello"+        , Wai.pathInfo      = ["hello"]+        }++  resultVar <- newEmptyMVar+  _ <- waiApp waiReq $ \waiResp -> do+    putMVar resultVar waiResp+    pure Wai.ResponseReceived+  waiResp <- takeMVar resultVar++  assert "toWaiApp: status 200" (Wai.responseStatus waiResp == status200)+  assert "toWaiApp: has Content-Type" $+    lookup "Content-Type" (Wai.responseHeaders waiResp) == Just "text/plain"+++-- ===================================================================+-- fromWaiRequest preserves fields+-- ===================================================================++testFromWaiRequest :: IO ()+testFromWaiRequest = do+  let waiReq = Wai.defaultRequest+        { Wai.requestMethod  = methodPost+        , Wai.rawPathInfo    = "/users/42"+        , Wai.pathInfo       = ["users", "42"]+        , Wai.queryString    = [("format", Just "json")]+        , Wai.requestHeaders = [("Authorization", "Bearer token")]+        }+  req <- fromWaiRequest waiReq++  assert "fromWai: method" (requestMethod req == methodPost)+  assert "fromWai: rawPath" (requestPathRaw req == "/users/42")+  assert "fromWai: path segments" (requestPath req == ["users", "42"])+  assert "fromWai: query" (requestQuery req == [("format", Just "json")])+  assert "fromWai: headers" (lookup "Authorization" (requestHeaders req) == Just "Bearer token")+++-- ===================================================================+-- toWaiResponse roundtrip+-- ===================================================================++testToWaiResponse :: IO ()+testToWaiResponse = do+  let resp = ok [("X-Custom", "test")] "hello world"+      waiResp = toWaiResponse resp++  assert "toWaiResp: status 200" (Wai.responseStatus waiResp == status200)+  assert "toWaiResp: custom header" $+    lookup "X-Custom" (Wai.responseHeaders waiResp) == Just "test"+++-- ===================================================================+-- fromWaiMiddleware: wrapping WAI middleware as spire Layer+-- ===================================================================++testFromWaiMiddleware :: IO ()+testFromWaiMiddleware = do+  -- A WAI middleware that adds a response header+  let addHeader :: Wai.Middleware+      addHeader app waiReq respond = app waiReq $ \waiResp ->+        respond $ Wai.mapResponseHeaders (("X-WAI-MW", "present") :) waiResp++  let svc :: Service IO (Request ByteString) (Response ByteString)+      svc = Service $ \_ -> pure (ok [] "inner-body")++  let wrappedSvc = svc |> fromWaiMiddleware addHeader++  reqData <- defaultRequest+  resp <- runService wrappedSvc reqData++  -- The WAI middleware should have added the header.+  -- Note: the response body comes through via the inner toWaiApp/toWaiResponse+  -- path, so it's preserved.+  assert "fromWaiMiddleware: header added" $+    lookup "X-WAI-MW" (responseHeaders resp) == Just "present"+++-- ===================================================================+-- Integration: spire-http layers + spire-wai adapter+-- ===================================================================++testIntegration :: IO ()+testIntegration = do+  let svc :: Service IO (Request ByteString) (Response ByteString)+      svc = Service $ \_ -> pure (ok [] "ok")++  let fullSvc = svc |> secureHeadersLayer defaultSecureHeaders+      waiApp = toWaiApp fullSvc++  let waiReq = Wai.defaultRequest { Wai.rawPathInfo = "/" }+  resultVar <- newEmptyMVar+  _ <- waiApp waiReq $ \waiResp -> do+    putMVar resultVar waiResp+    pure Wai.ResponseReceived+  waiResp <- takeMVar resultVar++  assert "integration: security headers present" $+    lookup "X-Frame-Options" (Wai.responseHeaders waiResp) == Just "DENY"+++-- ===================================================================+-- Main+-- ===================================================================++main :: IO ()+main = do+  putStrLn "spire-wai tests:"+  putStrLn ""+  putStrLn "toWaiApp:"+  testToWaiApp+  putStrLn ""+  putStrLn "fromWaiRequest:"+  testFromWaiRequest+  putStrLn ""+  putStrLn "toWaiResponse:"+  testToWaiResponse+  putStrLn ""+  putStrLn "fromWaiMiddleware:"+  testFromWaiMiddleware+  putStrLn ""+  putStrLn "Integration:"+  testIntegration+  putStrLn ""+  putStrLn "All spire-wai tests passed."