warp-effectful 1.1.0 → 1.1.1

raw patch · 5 files changed

+134/−32 lines, 5 filesdep +containersdep +effectful-coredep −effectfulPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, effectful-core

Dependencies removed: effectful

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• src/Effectful/Wai/Handler/Warp.hs +50/−29
• src/ThreadEnvs.hs +48/−0
• test/Main.hs +22/−0
• warp-effectful.cabal +7/−3

@@ -5,6 +5,13 @@ 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.1.1] - 2026-10-01++### Changed++- Eliminated per-request lock contention when resolving connection environments.+- `runEnv`, `withApplication`, and `testWithApplication` correctly inherit custom `Settings` for environment setup.+ ## [1.1.0] - 2026-08-04  ### Changed

@@ -190,7 +190,11 @@     ) import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Handler.Warp.Internal qualified as WarpI+import System.Environment (lookupEnv) import System.TimeManager (Manager)+import Text.Read (readMaybe)+import ThreadEnvs (ThreadEnvs)+import ThreadEnvs qualified import Prelude  -- | Lifted 'Warp.Settings'.@@ -271,21 +275,26 @@         , ..         } -unliftSettings :: (IOE :> es) => (forall r. Eff es r -> IO r) -> Settings es -> Warp.Settings-unliftSettings unlift Settings{..} =+unliftSettings :: forall es. (IOE :> es) => ThreadEnvs es -> Settings es -> Warp.Settings+unliftSettings envs Settings{..} =     WarpI.Settings         { settingsOnException = (unlift .) . settingsOnException . fmap liftRequest         , settingsOnExceptionResponse = unliftResponse unlift . settingsOnExceptionResponse         , settingsOnOpen = unlift . settingsOnOpen         , settingsOnClose = unlift . settingsOnClose         , settingsBeforeMainLoop = unlift settingsBeforeMainLoop-        , settingsFork = \ioInner -> unlift $ settingsFork unlift \effUnmask -> liftIO . ioInner $ unlift . effUnmask . liftIO+        , settingsFork = \ioInner ->+            unlift $ settingsFork unlift \effUnmask ->+                liftIO . ThreadEnvs.with envs . ioInner $ unlift . effUnmask . liftIO         , settingsAccept = unlift . settingsAccept         , settingsInstallShutdownHandler = unlift . settingsInstallShutdownHandler . liftIO         , settingsLogger = \req st ms -> unlift (settingsLogger (liftRequest req) st ms)         , settingsServerPushLogger = ((unlift .) .) . settingsServerPushLogger . liftRequest         , ..         }+  where+    unlift :: forall r. Eff es r -> IO r+    unlift = ThreadEnvs.unlift envs  -- | Lifted 'Warp.run'. run :: (IOE :> es) => Port -> Application es -> Eff es ()@@ -294,20 +303,30 @@ -- | Lifted 'Warp.runEnv'. runEnv :: (IOE :> es) => Port -> Application es -> Eff es () runEnv port app =-    withEffToIO (ConcUnlift Persistent Unlimited) \unlift ->-        Warp.runEnv port (unliftApplication unlift app)+    liftIO (lookupEnv "PORT") >>= \case+        Nothing -> run port app+        Just sp -> case readMaybe sp of+            Just port' -> run port' app+            _ -> liftIO . fail $ "Invalid value in PORT: " <> sp  -- | Lifted 'Warp.runSettings'. runSettings :: (IOE :> es) => Settings es -> Application es -> Eff es ()-runSettings settings app =-    withEffToIO (ConcUnlift Persistent Unlimited) \unlift ->-        Warp.runSettings (unliftSettings unlift settings) (unliftApplication unlift app)+runSettings settings app = do+    envs <- ThreadEnvs.new+    liftIO $+        Warp.runSettings+            (unliftSettings envs settings)+            (unliftApplication (ThreadEnvs.unlift envs) app)  -- | Lifted 'Warp.runSettingsSocket'. runSettingsSocket :: (IOE :> es) => Settings es -> Socket -> Application es -> Eff es ()-runSettingsSocket settings socket app =-    withEffToIO (ConcUnlift Persistent Unlimited) \unlift ->-        Warp.runSettingsSocket (unliftSettings unlift settings) socket (unliftApplication unlift app)+runSettingsSocket settings socket app = do+    envs <- ThreadEnvs.new+    liftIO $+        Warp.runSettingsSocket+            (unliftSettings envs settings)+            socket+            (unliftApplication (ThreadEnvs.unlift envs) app)  -- | Lifted 'Warp.setPort'. setPort :: Port -> Settings es -> Settings es@@ -532,45 +551,47 @@  -- | Lifted 'Warp.withApplication'. withApplication :: (IOE :> es) => Eff es (Application es) -> (Port -> Eff es a) -> Eff es a-withApplication mkApp k =-    withEffToIO (ConcUnlift Persistent Unlimited) \unlift -> do-        app <- unlift mkApp-        Warp.withApplication (pure (unliftApplication unlift app)) (unlift . k)+withApplication = withApplicationSettings defaultSettings  -- | Lifted 'Warp.withApplicationSettings'. withApplicationSettings-    :: (IOE :> es)+    :: forall es a+     . (IOE :> es)     => Settings es     -> Eff es (Application es)     -> (Port -> Eff es a)     -> Eff es a-withApplicationSettings settings mkApp k =-    withEffToIO (ConcUnlift Persistent Unlimited) \unlift -> do-        app <- unlift mkApp+withApplicationSettings settings mkApp k = do+    envs <- ThreadEnvs.new+    app <- mkApp+    let unlift :: Eff es r -> IO r+        unlift = ThreadEnvs.unlift envs+    liftIO $         Warp.withApplicationSettings-            (unliftSettings unlift settings)+            (unliftSettings envs settings)             (pure (unliftApplication unlift app))             (unlift . k)  -- | Lifted 'Warp.testWithApplication'. testWithApplication :: (IOE :> es) => Eff es (Application es) -> (Port -> Eff es a) -> Eff es a-testWithApplication mkApp k =-    withEffToIO (ConcUnlift Persistent Unlimited) \unlift -> do-        app <- unlift mkApp-        Warp.testWithApplication (pure (unliftApplication unlift app)) (unlift . k)+testWithApplication = testWithApplicationSettings defaultSettings  -- | Lifted 'Warp.testWithApplicationSettings'. testWithApplicationSettings-    :: (IOE :> es)+    :: forall es a+     . (IOE :> es)     => Settings es     -> Eff es (Application es)     -> (Port -> Eff es a)     -> Eff es a-testWithApplicationSettings settings mkApp k =-    withEffToIO (ConcUnlift Persistent Unlimited) \unlift -> do-        app <- unlift mkApp+testWithApplicationSettings settings mkApp k = do+    envs <- ThreadEnvs.new+    app <- mkApp+    let unlift :: Eff es r -> IO r+        unlift = ThreadEnvs.unlift envs+    liftIO $         Warp.testWithApplicationSettings-            (unliftSettings unlift settings)+            (unliftSettings envs settings)             (pure (unliftApplication unlift app))             (unlift . k) 

@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module ThreadEnvs where++import Control.Concurrent (ThreadId, myThreadId)+import Control.Exception (bracket_)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Effectful+import Effectful.Dispatch.Static (unEff, unsafeEff)+import Effectful.Internal.Env (Env, cloneEnv)+import Prelude++-- | Per-thread 'Env' cache backing the unlifting function handed to Warp.+data ThreadEnvs es = ThreadEnvs+    { owner :: ThreadId+    , ownerEnv :: Env es+    , template :: Env es+    , cache :: IORef (Map ThreadId (Env es))+    }++new :: Eff es (ThreadEnvs es)+new = unsafeEff \ownerEnv -> do+    owner <- myThreadId+    template <- cloneEnv ownerEnv+    cache <- newIORef mempty+    pure ThreadEnvs{..}++-- | Give the calling thread its own environment for the duration of the action.+with :: ThreadEnvs es -> IO a -> IO a+with ThreadEnvs{..} action = do+    tid <- myThreadId+    es <- cloneEnv template+    bracket_+        (atomicModifyIORef' cache \cache -> (Map.insert tid es cache, ()))+        (atomicModifyIORef' cache \cache -> (Map.delete tid cache, ()))+        action++-- | Unlift using the calling thread's own environment.+unlift :: ThreadEnvs es -> Eff es r -> IO r+unlift ThreadEnvs{..} m = do+    tid <- myThreadId+    if tid == owner+        then unEff m ownerEnv+        else do+            cache <- readIORef cache+            unEff m =<< maybe (cloneEnv template) pure (Map.lookup tid cache)

@@ -1,9 +1,13 @@ module Main where +import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)+import Control.Monad (replicateM) import Data.ByteString.Lazy (LazyByteString)+import Data.ByteString.Lazy.Char8 qualified as LazyByteString import Effectful import Effectful.Hspec import Effectful.HttpClient+import Effectful.State.Static.Local (State, evalState, get, modify) import Effectful.Wai hiding (Response, responseStatus) import Effectful.Wai.Handler.Warp import Network.HTTP.Types qualified as HTTP@@ -41,3 +45,21 @@         (_counter, settings) <- makeSettingsAndCounter         resp <- testWithApplicationSettings settings (pure app) (post mempty)         responseStatus resp `shouldBe` HTTP.ok200++    it "gives each connection its own copy of the environment" do+        let app :: (State Int :> es) => Application es+            app _req respond = do+                modify @Int (+ 1)+                n <- get @Int+                respond . responseLBS HTTP.ok200 [] . LazyByteString.pack $ show n+            connections :: Int+            connections = 64+        bodies <- evalState @Int 0 $ withApplication (pure app) \port ->+            replicateConcurrently connections $ responseBody <$> post mempty port+        bodies `shouldBe` replicate connections "1"++replicateConcurrently :: (IOE :> es) => Int -> Eff es a -> Eff es [a]+replicateConcurrently n action = withEffToIO (ConcUnlift Persistent Unlimited) \unlift -> do+    dones <- replicateM n newEmptyMVar+    mapM_ (\done -> forkIO $ unlift action >>= putMVar done) dones+    mapM takeMVar dones

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: warp-effectful-version: 1.1.0+version: 1.1.1 synopsis: Effectful bindings for the warp library description:   Adaptation of the @<https://hackage.haskell.org/package/warp warp>@ library for the @<https://hackage.haskell.org/package/effectful effectful>@ ecosystem.@@ -13,7 +13,7 @@ bug-reports: https://issues.digital-autonomy.institute category: Network build-type: Simple-extra-source-files:+extra-doc-files:   CHANGELOG.md  common common@@ -49,7 +49,7 @@   build-depends:     base >=4.10 && <5,     bytestring >=0.12 && <0.13,-    effectful >=2.6 && <2.7,+    effectful-core >=2.6 && <2.8,     http-types >=0.12 && <0.13,     wai-effectful >=1.0 && <1.1, @@ -57,6 +57,7 @@   import: common   hs-source-dirs: src   build-depends:+    containers >=0.6 && <0.9,     crypton-x509 >=1.7 && <1.10,     network >=3.2 && <3.3,     time-manager >=0.2 && <0.4,@@ -64,6 +65,9 @@    exposed-modules:     Effectful.Wai.Handler.Warp++  other-modules:+    ThreadEnvs  test-suite test   import: common