wai-effectful 1.0.1 → 1.0.2

raw patch · 6 files changed

+94/−58 lines, 6 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• Setup.hs +0/−2
• src/Effectful/Wai.hs +11/−50
• src/Effectful/Wai/Internal.hs +49/−0
• test/Main.hs +21/−5
• wai-effectful.cabal +3/−1

@@ -5,6 +5,16 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [1.0.2] - 2026-11-07++### Added++- `Effectful.Wai.Internal` with the constructors of `Request` and `Response`.++### Fixed++- Lifted raw responses can read and write from different threads.+ ## [1.0.1] - 2026-10-01  ### Changed

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -118,13 +118,11 @@ import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder, lazyByteString) import Data.ByteString.Lazy (LazyByteString)-import Data.Text (Text)-import Data.Vault.Lazy (Vault) import Effectful-import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders, ResponseHeaders, Status)-import Network.Socket (SockAddr)-import Network.Wai (FilePart (..), RequestBodyLength (..), ResponseReceived)+import Effectful.Wai.Internal+import Network.HTTP.Types (RequestHeaders, ResponseHeaders, Status) import Network.Wai qualified as Wai+import Network.Wai.Internal (FilePart (..), RequestBodyLength (..), ResponseReceived) import Network.Wai.Internal qualified as Wai import Prelude @@ -158,26 +156,6 @@ unliftMiddleware :: (IOE :> es) => (forall r. Eff es r -> IO r) -> Middleware es -> Wai.Middleware unliftMiddleware unlift middleware = unliftApplication unlift . middleware . liftApplication --- | Lifted 'Wai.Request'.-data Request es = Request-    { requestMethod :: Method-    , httpVersion :: HttpVersion-    , rawPathInfo :: ByteString-    , rawQueryString :: ByteString-    , requestHeaders :: RequestHeaders-    , isSecure :: Bool-    , remoteHost :: Network.Socket.SockAddr-    , pathInfo :: [Text]-    , queryString :: Query-    , requestBody :: Eff es ByteString-    , vault :: Vault-    , requestBodyLength :: RequestBodyLength-    , requestHeaderHost :: Maybe ByteString-    , requestHeaderRange :: Maybe ByteString-    , requestHeaderReferer :: Maybe ByteString-    , requestHeaderUserAgent :: Maybe ByteString-    }- liftRequest :: (IOE :> es) => Wai.Request -> Request es liftRequest Wai.Request{..} =     Request@@ -203,10 +181,6 @@ defaultRequest :: (IOE :> es) => Request es defaultRequest = liftRequest Wai.defaultRequest --- | Lifted 'Wai.getRequestBodyChunk'.-getRequestBodyChunk :: Request es -> Eff es ByteString-getRequestBodyChunk = requestBody- -- | Lifted 'Wai.strictRequestBody'. strictRequestBody :: (IOE :> es) => Request es -> Eff es LazyByteString strictRequestBody = withSeqEffToIO . (Wai.strictRequestBody .) . flip unliftRequest@@ -223,32 +197,22 @@ consumeRequestBodyLazy :: (IOE :> es) => Request es -> Eff es LazyByteString consumeRequestBodyLazy = lazyRequestBody --- | Lifted 'Wai.setRequestBodyChunks'.-setRequestBodyChunks :: Eff es ByteString -> Request es -> Request es-setRequestBodyChunks body req = req{requestBody = body}- -- | Lifted 'Wai.mapRequestHeaders'. mapRequestHeaders     :: (RequestHeaders -> RequestHeaders)     -> Request es     -> Request es-mapRequestHeaders f req = req{requestHeaders = f (requestHeaders req)}---- | Lifted 'Wai.Response'.-data Response es-    = ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)-    | ResponseBuilder Status ResponseHeaders Builder-    | ResponseStream Status ResponseHeaders (StreamingBody es)-    | ResponseRaw (Eff es ByteString -> (ByteString -> Eff es ()) -> Eff es ()) (Response es)+mapRequestHeaders f req = req{requestHeaders = f $ requestHeaders req}  liftResponse :: forall es. (IOE :> es) => Wai.Response -> Response es liftResponse (Wai.ResponseFile s h fp part) = ResponseFile s h fp part liftResponse (Wai.ResponseBuilder s h b) = ResponseBuilder s h b-liftResponse (Wai.ResponseStream s h body) = ResponseStream s h (liftStreamingBody body)-liftResponse (Wai.ResponseRaw raw res) = ResponseRaw liftRaw (liftResponse res)+liftResponse (Wai.ResponseStream s h body) = ResponseStream s h $ liftStreamingBody body+liftResponse (Wai.ResponseRaw raw res) = ResponseRaw liftRaw $ liftResponse res   where     liftRaw :: Eff es ByteString -> (ByteString -> Eff es ()) -> Eff es ()-    liftRaw recv send = withRunInIO \unlift -> raw (unlift recv) (unlift . send)+    liftRaw recv send =+        withEffToIO (ConcUnlift Ephemeral Unlimited) \unlift -> raw (unlift recv) (unlift . send)  unliftResponse     :: forall es@@ -258,17 +222,14 @@     -> Wai.Response unliftResponse _ (ResponseFile s h fp part) = Wai.ResponseFile s h fp part unliftResponse _ (ResponseBuilder s h b) = Wai.ResponseBuilder s h b-unliftResponse unlift (ResponseStream s h body) = Wai.ResponseStream s h (unliftStreamingBody unlift body)-unliftResponse unlift (ResponseRaw raw res) = Wai.ResponseRaw unliftRaw (unliftResponse unlift res)+unliftResponse unlift (ResponseStream s h body) = Wai.ResponseStream s h $ unliftStreamingBody unlift body+unliftResponse unlift (ResponseRaw raw res) = Wai.ResponseRaw unliftRaw $ unliftResponse unlift res   where     unliftRaw :: IO ByteString -> (ByteString -> IO ()) -> IO ()     unliftRaw recv send = unlift $ raw (liftIO recv) (liftIO . send) --- | Lifted 'Wai.StreamingBody'.-type StreamingBody es = (Builder -> Eff es ()) -> Eff es () -> Eff es ()- liftStreamingBody :: (IOE :> es) => Wai.StreamingBody -> StreamingBody es-liftStreamingBody body send flush = withRunInIO \unlift -> body (unlift . send) (unlift flush)+liftStreamingBody body send flush = withRunInIO \unlift -> body (unlift . send) $ unlift flush  unliftStreamingBody     :: (IOE :> es)

@@ -0,0 +1,49 @@+module Effectful.Wai.Internal where++import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import Data.Text (Text)+import Data.Vault.Lazy (Vault)+import Effectful+import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders, ResponseHeaders, Status)+import Network.Socket (SockAddr)+import Network.Wai (FilePart (..), RequestBodyLength (..))+import Prelude++-- | Lifted 'Network.Wai.Request'.+data Request es = Request+    { requestMethod :: Method+    , httpVersion :: HttpVersion+    , rawPathInfo :: ByteString+    , rawQueryString :: ByteString+    , requestHeaders :: RequestHeaders+    , isSecure :: Bool+    , remoteHost :: SockAddr+    , pathInfo :: [Text]+    , queryString :: Query+    , requestBody :: Eff es ByteString+    , vault :: Vault+    , requestBodyLength :: RequestBodyLength+    , requestHeaderHost :: Maybe ByteString+    , requestHeaderRange :: Maybe ByteString+    , requestHeaderReferer :: Maybe ByteString+    , requestHeaderUserAgent :: Maybe ByteString+    }++-- | Lifted 'Network.Wai.getRequestBodyChunk'.+getRequestBodyChunk :: Request es -> Eff es ByteString+getRequestBodyChunk = requestBody++-- | Lifted 'Network.Wai.setRequestBodyChunks'.+setRequestBodyChunks :: Eff es ByteString -> Request es -> Request es+setRequestBodyChunks body req = req{requestBody = body}++-- | Lifted 'Network.Wai.Response'.+data Response es+    = ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)+    | ResponseBuilder Status ResponseHeaders Builder+    | ResponseStream Status ResponseHeaders (StreamingBody es)+    | ResponseRaw (Eff es ByteString -> (ByteString -> Eff es ()) -> Eff es ()) (Response es)++-- | Lifted 'Network.Wai.StreamingBody'.+type StreamingBody es = (Builder -> Eff es ()) -> Eff es () -> Eff es ()

@@ -3,6 +3,8 @@  module Main where +import Control.Concurrent (forkFinally, newEmptyMVar, putMVar, takeMVar)+import Control.Monad (void) import Data.ByteString qualified as ByteString import Data.ByteString.Builder (toLazyByteString, word8) import Data.ByteString.Lazy qualified as LazyByteString@@ -16,6 +18,7 @@ import Effectful.Hspec import Effectful.Prim.IORef import Effectful.Wai+import Network.Wai.Internal qualified as Wai import Prelude hiding (readFile)  main :: IO ()@@ -38,7 +41,7 @@         prop "responseStream" \chunks -> do             body <- getBody $ responseStream undefined undefined \sendChunk _ ->                 for_ chunks $ sendChunk . foldMap word8-            body `shouldBe` ByteString.concat (map ByteString.pack chunks)+            body `shouldBe` ByteString.concat (fmap ByteString.pack chunks)         it "responseFile total" do             let fp = "LICENCE"             body <- getBody $ responseFile undefined undefined fp Nothing@@ -59,6 +62,19 @@                         }             let expected = ByteString.take count $ ByteString.drop offset totalBS             body `shouldBe` expected+    describe "liftResponse" do+        it "lifts a raw response that sends from another thread" do+            failure <- liftIO newEmptyMVar+            let raw recv send = do+                    chunk <- recv+                    void . forkFinally (send chunk) $+                        putMVar failure . either (Just . show) (const Nothing)+                fallback = Wai.ResponseBuilder undefined undefined mempty+            withSeqEffToIO \unlift ->+                case unliftResponse unlift . liftResponse $ Wai.ResponseRaw raw fallback of+                    Wai.ResponseRaw run _ -> run (pure "chunk") . const $ pure ()+                    _ -> fail "not a raw response"+            liftIO (takeMVar failure) >>= (`shouldBe` Nothing)     describe "lazyRequestBody" do         prop "works" \chunks -> do             req <- mkRequestFromChunks chunks@@ -67,15 +83,15 @@         it "is lazy" do             let req = setRequestBodyChunks (error "requestBody") defaultRequest             _ <- lazyRequestBody req-            return ()+            pure ()     describe "strictRequestBody" do         prop "works" $ \chunks -> do             req <- mkRequestFromChunks chunks             body <- strictRequestBody req-            body `shouldBe` LazyByteString.fromChunks (map ByteString.pack chunks)+            body `shouldBe` LazyByteString.fromChunks (fmap ByteString.pack chunks)  mkRequestFromChunks :: (IOE :> es, Prim :> es) => [[Word8]] -> Eff es (Request es) mkRequestFromChunks chunks = do-    ref <- newIORef . map ByteString.pack . filter (not . null) $ chunks+    ref <- newIORef . fmap ByteString.pack . filter (not . null) $ chunks     pure . flip setRequestBodyChunks defaultRequest . atomicModifyIORef ref $-        maybe mempty Tuple.swap . List.uncons+        foldMap Tuple.swap . List.uncons

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: wai-effectful-version: 1.0.1+version: 1.0.2 synopsis: Effectful bindings for the wai library description:   Adaptation of the @<https://hackage.haskell.org/package/wai wai>@ library for the @<https://hackage.haskell.org/package/effectful effectful>@ ecosystem.@@ -64,6 +64,7 @@    exposed-modules:     Effectful.Wai+    Effectful.Wai.Internal  test-suite test   import: common@@ -72,4 +73,5 @@   main-is: Main.hs   build-depends:     hspec-effectful >=1.1.1 && <1.2,+    wai >=3.2.4 && <3.3,     wai-effectful,