warp-effectful (empty) → 1.0.0

raw patch · 6 files changed

+1007/−0 lines, 6 filesdep +basedep +bytestringdep +crypton-x509setup-changed

Dependencies added: base, bytestring, crypton-x509, effectful, hspec-effectful, http-client-effectful, http-types, network, time-manager, wai-effectful, warp, warp-effectful

Files

• CHANGELOG.md +12/−0
• LICENCE +287/−0
• Setup.hs +2/−0
• src/Effectful/Wai/Handler/Warp.hs +587/−0
• test/Main.hs +43/−0
• warp-effectful.cabal +76/−0

@@ -0,0 +1,12 @@+# Changelog++All notable changes to this project will be documented in this file.++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/).++## [Unreleased]++### Added++- Initial release.

@@ -0,0 +1,287 @@+                      EUROPEAN UNION PUBLIC LICENCE v. 1.2+                      EUPL © the European Union 2007, 2016++This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined+below) which is provided under the terms of this Licence. Any use of the Work,+other than as authorised under this Licence is prohibited (to the extent such+use is covered by a right of the copyright holder of the Work).++The Work is provided under the terms of this Licence when the Licensor (as+defined below) has placed the following notice immediately following the+copyright notice for the Work:++        Licensed under the EUPL++or has expressed by any other means his willingness to license under the EUPL.++1. Definitions++In this Licence, the following terms have the following meaning:++- ‘The Licence’: this Licence.++- ‘The Original Work’: the work or software distributed or communicated by the+  Licensor under this Licence, available as Source Code and also as Executable+  Code as the case may be.++- ‘Derivative Works’: the works or software that could be created by the+  Licensee, based upon the Original Work or modifications thereof. This Licence+  does not define the extent of modification or dependence on the Original Work+  required in order to classify a work as a Derivative Work; this extent is+  determined by copyright law applicable in the country mentioned in Article 15.++- ‘The Work’: the Original Work or its Derivative Works.++- ‘The Source Code’: the human-readable form of the Work which is the most+  convenient for people to study and modify.++- ‘The Executable Code’: any code which has generally been compiled and which is+  meant to be interpreted by a computer as a program.++- ‘The Licensor’: the natural or legal person that distributes or communicates+  the Work under the Licence.++- ‘Contributor(s)’: any natural or legal person who modifies the Work under the+  Licence, or otherwise contributes to the creation of a Derivative Work.++- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of+  the Work under the terms of the Licence.++- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending,+  renting, distributing, communicating, transmitting, or otherwise making+  available, online or offline, copies of the Work or providing access to its+  essential functionalities at the disposal of any other natural or legal+  person.++2. Scope of the rights granted by the Licence++The Licensor hereby grants You a worldwide, royalty-free, non-exclusive,+sublicensable licence to do the following, for the duration of copyright vested+in the Original Work:++- use the Work in any circumstance and for all usage,+- reproduce the Work,+- modify the Work, and make Derivative Works based upon the Work,+- communicate to the public, including the right to make available or display+  the Work or copies thereof to the public and perform publicly, as the case may+  be, the Work,+- distribute the Work or copies thereof,+- lend and rent the Work or copies thereof,+- sublicense rights in the Work or copies thereof.++Those rights can be exercised on any media, supports and formats, whether now+known or later invented, as far as the applicable law permits so.++In the countries where moral rights apply, the Licensor waives his right to+exercise his moral right to the extent allowed by law in order to make effective+the licence of the economic rights here above listed.++The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to+any patents held by the Licensor, to the extent necessary to make use of the+rights granted on the Work under this Licence.++3. Communication of the Source Code++The Licensor may provide the Work either in its Source Code form, or as+Executable Code. If the Work is provided as Executable Code, the Licensor+provides in addition a machine-readable copy of the Source Code of the Work+along with each copy of the Work that the Licensor distributes or indicates, in+a notice following the copyright notice attached to the Work, a repository where+the Source Code is easily and freely accessible for as long as the Licensor+continues to distribute or communicate the Work.++4. Limitations on copyright++Nothing in this Licence is intended to deprive the Licensee of the benefits from+any exception or limitation to the exclusive rights of the rights owners in the+Work, of the exhaustion of those rights or of other applicable limitations+thereto.++5. Obligations of the Licensee++The grant of the rights mentioned above is subject to some restrictions and+obligations imposed on the Licensee. Those obligations are the following:++Attribution right: The Licensee shall keep intact all copyright, patent or+trademarks notices and all notices that refer to the Licence and to the+disclaimer of warranties. The Licensee must include a copy of such notices and a+copy of the Licence with every copy of the Work he/she distributes or+communicates. The Licensee must cause any Derivative Work to carry prominent+notices stating that the Work has been modified and the date of modification.++Copyleft clause: If the Licensee distributes or communicates copies of the+Original Works or Derivative Works, this Distribution or Communication will be+done under the terms of this Licence or of a later version of this Licence+unless the Original Work is expressly distributed only under this version of the+Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee+(becoming Licensor) cannot offer or impose any additional terms or conditions on+the Work or Derivative Work that alter or restrict the terms of the Licence.++Compatibility clause: If the Licensee Distributes or Communicates Derivative+Works or copies thereof based upon both the Work and another work licensed under+a Compatible Licence, this Distribution or Communication can be done under the+terms of this Compatible Licence. For the sake of this clause, ‘Compatible+Licence’ refers to the licences listed in the appendix attached to this Licence.+Should the Licensee's obligations under the Compatible Licence conflict with+his/her obligations under this Licence, the obligations of the Compatible+Licence shall prevail.++Provision of Source Code: When distributing or communicating copies of the Work,+the Licensee will provide a machine-readable copy of the Source Code or indicate+a repository where this Source will be easily and freely available for as long+as the Licensee continues to distribute or communicate the Work.++Legal Protection: This Licence does not grant permission to use the trade names,+trademarks, service marks, or names of the Licensor, except as required for+reasonable and customary use in describing the origin of the Work and+reproducing the content of the copyright notice.++6. Chain of Authorship++The original Licensor warrants that the copyright in the Original Work granted+hereunder is owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each Contributor warrants that the copyright in the modifications he/she brings+to the Work are owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each time You accept the Licence, the original Licensor and subsequent+Contributors grant You a licence to their contributions to the Work, under the+terms of this Licence.++7. Disclaimer of Warranty++The Work is a work in progress, which is continuously improved by numerous+Contributors. It is not a finished work and may therefore contain defects or+‘bugs’ inherent to this type of development.++For the above reason, the Work is provided under the Licence on an ‘as is’ basis+and without warranties of any kind concerning the Work, including without+limitation merchantability, fitness for a particular purpose, absence of defects+or errors, accuracy, non-infringement of intellectual property rights other than+copyright as stated in Article 6 of this Licence.++This disclaimer of warranty is an essential part of the Licence and a condition+for the grant of any rights to the Work.++8. Disclaimer of Liability++Except in the cases of wilful misconduct or damages directly caused to natural+persons, the Licensor will in no event be liable for any direct or indirect,+material or moral, damages of any kind, arising out of the Licence or of the use+of the Work, including without limitation, damages for loss of goodwill, work+stoppage, computer failure or malfunction, loss of data or any commercial+damage, even if the Licensor has been advised of the possibility of such damage.+However, the Licensor will be liable under statutory product liability laws as+far such laws apply to the Work.++9. Additional agreements++While distributing the Work, You may choose to conclude an additional agreement,+defining obligations or services consistent with this Licence. However, if+accepting obligations, You may act only on your own behalf and on your sole+responsibility, not on behalf of the original Licensor or any other Contributor,+and only if You agree to indemnify, defend, and hold each Contributor harmless+for any liability incurred by, or claims asserted against such Contributor by+the fact You have accepted any warranty or additional liability.++10. Acceptance of the Licence++The provisions of this Licence can be accepted by clicking on an icon ‘I agree’+placed under the bottom of a window displaying the text of this Licence or by+affirming consent in any other similar way, in accordance with the rules of+applicable law. Clicking on that icon indicates your clear and irrevocable+acceptance of this Licence and all of its terms and conditions.++Similarly, you irrevocably accept this Licence and all of its terms and+conditions by exercising any rights granted to You by Article 2 of this Licence,+such as the use of the Work, the creation by You of a Derivative Work or the+Distribution or Communication by You of the Work or copies thereof.++11. Information to the public++In case of any Distribution or Communication of the Work by means of electronic+communication by You (for example, by offering to download the Work from a+remote location) the distribution channel or media (for example, a website) must+at least provide to the public the information requested by the applicable law+regarding the Licensor, the Licence and the way it may be accessible, concluded,+stored and reproduced by the Licensee.++12. Termination of the Licence++The Licence and the rights granted hereunder will terminate automatically upon+any breach by the Licensee of the terms of the Licence.++Such a termination will not terminate the licences of any person who has+received the Work from the Licensee under the Licence, provided such persons+remain in full compliance with the Licence.++13. Miscellaneous++Without prejudice of Article 9 above, the Licence represents the complete+agreement between the Parties as to the Work.++If any provision of the Licence is invalid or unenforceable under applicable+law, this will not affect the validity or enforceability of the Licence as a+whole. Such provision will be construed or reformed so as necessary to make it+valid and enforceable.++The European Commission may publish other linguistic versions or new versions of+this Licence or updated versions of the Appendix, so far this is required and+reasonable, without reducing the scope of the rights granted by the Licence. New+versions of the Licence will be published with a unique version number.++All linguistic versions of this Licence, approved by the European Commission,+have identical value. Parties can take advantage of the linguistic version of+their choice.++14. Jurisdiction++Without prejudice to specific agreement between parties,++- any litigation resulting from the interpretation of this License, arising+  between the European Union institutions, bodies, offices or agencies, as a+  Licensor, and any Licensee, will be subject to the jurisdiction of the Court+  of Justice of the European Union, as laid down in article 272 of the Treaty on+  the Functioning of the European Union,++- any litigation arising between other parties and resulting from the+  interpretation of this License, will be subject to the exclusive jurisdiction+  of the competent court where the Licensor resides or conducts its primary+  business.++15. Applicable Law++Without prejudice to specific agreement between parties,++- this Licence shall be governed by the law of the European Union Member State+  where the Licensor has his seat, resides or has his registered office,++- this licence shall be governed by Belgian law if the Licensor has no seat,+  residence or registered office inside a European Union Member State.++Appendix++‘Compatible Licences’ according to Article 5 EUPL are:++- GNU General Public License (GPL) v. 2, v. 3+- GNU Affero General Public License (AGPL) v. 3+- Open Software License (OSL) v. 2.1, v. 3.0+- Eclipse Public License (EPL) v. 1.0+- CeCILL v. 2.0, v. 2.1+- Mozilla Public Licence (MPL) v. 2+- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3+- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for+  works other than software+- European Union Public Licence (EUPL) v. 1.1, v. 1.2+- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong+  Reciprocity (LiLiQ-R+).++The European Commission may update this Appendix to later versions of the above+licences without producing a new version of the EUPL, as long as they provide+the rights granted in Article 2 of this Licence and protect the covered Source+Code from exclusive appropriation.++All other changes or additions to this Appendix require the production of a new+EUPL version.

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

@@ -0,0 +1,587 @@+{-# LANGUAGE Trustworthy #-}++-- |+-- Module      : Effectful.Wai.Handler.Warp+-- Copyright   : (c) 2026 Institute for Digital Autonomy+-- License     : EUPL-1.2+-- Maintainer  : IDA+--+-- Effectful bindings for the <http://hackage.haskell.org/package/warp warp library>.+--+-- = Example usage+--+-- Here is an 'Application' that serves requests using an arbitrary effect stack;+-- in this case it uses the 'State' effect to count the number of requests.+--+-- Run it using one of the 'run' functions:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Effectful+-- > import Effectful.State.Static.Local (State, evalState, modify)+-- > import Effectful.Wai (Application, responseLBS)+-- > import Effectful.Wai.Handler.Warp qualified as Warp+-- > import Network.HTTP.Types (status200)+-- >+-- > app :: (State Int :> es) => Application es+-- > app _ respond = do+-- >     modify @Int succ+-- >     respond $+-- >         responseLBS+-- >             status200+-- >             [("Content-Type", "text/plain")]+-- >             "Hello, Web!"+-- >+-- > main :: IO ()+-- > main = runEff . evalState @Int 0 . Warp.run 8080 $ app+module Effectful.Wai.Handler.Warp+    ( -- * Run a Warp server++      -- | All of these automatically serve the same 'Application' over HTTP\/1,+      -- HTTP\/1.1, and HTTP\/2.+      run+    , runEnv+    , runSettings+    , runSettingsSocket++      -- * Settings+    , Settings+    , defaultSettings++      -- ** Setters+    , setPort+    , setHost+    , setOnException+    , setOnExceptionResponse+    , setOnOpen+    , setOnClose+    , setTimeout+    , setManager+    , setFdCacheDuration+    , setFileInfoCacheDuration+    , setBeforeMainLoop+    , setNoParsePath+    , setInstallShutdownHandler+    , setServerName+    , setMaximumBodyFlush+    , setFork+    , setAccept+    , setProxyProtocolNone+    , setProxyProtocolRequired+    , setProxyProtocolOptional+    , setSlowlorisSize+    , setHTTP2Disabled+    , setLogger+    , setServerPushLogger+    , setGracefulShutdownTimeout+    , setGracefulCloseTimeout1+    , setGracefulCloseTimeout2+    , setMaxTotalHeaderLength+    , setAltSvc+    , setMaxBuilderResponseBufferSize++      -- ** Getters+    , getPort+    , getHost+    , getOnOpen+    , getOnClose+    , getOnException+    , getGracefulShutdownTimeout+    , getGracefulCloseTimeout1+    , getGracefulCloseTimeout2+    , getOpenConnectionCounter+    , getServerState++      -- ** Internal server state+    , ServerState+    , makeSettingsAndServerState+    , currentOpenConnections+    , currentShuttingDownState++      -- *** STM versions+    , Warp.currentOpenConnectionsSTM+    , Warp.currentShuttingDownStateSTM++      -- ** Connection counter+    , makeSettingsAndCounter+    , Counter+    , getCount++      -- ** Exception handler+    , defaultOnException+    , defaultShouldDisplayException++      -- ** Exception response handler+    , defaultOnExceptionResponse+    , exceptionResponseForDebug++      -- * Data types+    , HostPreference+    , Port+    , InvalidRequest (..)++      -- * Utilities+    , pauseTimeout+    , FileInfo (..)+    , getFileInfo+    , clientCertificate+    , withApplication+    , withApplicationSettings+    , testWithApplication+    , testWithApplicationSettings+    , openFreePort++      -- * Version+    , warpVersion++      -- * HTTP/2++      -- ** HTTP2 data+    , HTTP2Data+    , http2dataPushPromise+    , http2dataTrailers+    , defaultHTTP2Data+    , getHTTP2Data+    , setHTTP2Data+    , modifyHTTP2Data++      -- ** Push promise+    , PushPromise+    , promisedPath+    , promisedFile+    , promisedResponseHeaders+    , promisedWeight+    , defaultPushPromise+    )+where++import Control.Concurrent (forkIOWithUnmask)+import Control.Exception (SomeException)+import Control.Monad (void)+import Data.Bifunctor (second)+import Data.ByteString (ByteString)+import Data.X509 (CertificateChain)+import Effectful+import Effectful.Wai+    ( Application+    , Request+    , Response+    , liftRequest+    , liftResponse+    , unliftApplication+    , unliftRequestNoBody+    , unliftResponse+    )+import Network.HTTP.Types qualified as HTTP+import Network.Socket (SockAddr, Socket, accept)+import Network.Wai.Handler.Warp+    ( Counter+    , FileInfo+    , HTTP2Data (..)+    , HostPreference+    , InvalidRequest+    , Port+    , PushPromise (..)+    , ServerState+    , defaultHTTP2Data+    , defaultPushPromise+    , defaultShouldDisplayException+    , getCount+    , warpVersion+    )+import Network.Wai.Handler.Warp qualified as Warp+import Network.Wai.Handler.Warp.Internal qualified as WarpI+import System.TimeManager (Manager)+import Prelude++-- | Lifted 'Warp.Settings'.+data Settings es = Settings+    { settingsPort :: Port+    , settingsHost :: HostPreference+    , settingsOnException :: Maybe (Request es) -> SomeException -> Eff es ()+    , settingsOnExceptionResponse :: SomeException -> Response es+    , settingsOnOpen :: SockAddr -> Eff es Bool+    , settingsOnClose :: SockAddr -> Eff es ()+    , settingsTimeout :: Int+    , settingsManager :: Maybe Manager+    , settingsFdCacheDuration :: Int+    , settingsFileInfoCacheDuration :: Int+    , settingsBeforeMainLoop :: Eff es ()+    , settingsFork :: ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es ()+    , settingsAccept :: Socket -> Eff es (Socket, SockAddr)+    , settingsNoParsePath :: Bool+    , settingsInstallShutdownHandler :: Eff es () -> Eff es ()+    , settingsServerName :: ByteString+    , settingsMaximumBodyFlush :: Maybe Int+    , settingsProxyProtocol :: WarpI.ProxyProtocol+    , settingsSlowlorisSize :: Int+    , settingsHTTP2Enabled :: Bool+    , settingsLogger :: Request es -> HTTP.Status -> Maybe Integer -> Eff es ()+    , settingsServerPushLogger :: Request es -> ByteString -> Integer -> Eff es ()+    , settingsGracefulShutdownTimeout :: Maybe Int+    , settingsGracefulCloseTimeout1 :: Int+    , settingsGracefulCloseTimeout2 :: Int+    , settingsMaxTotalHeaderLength :: Int+    , settingsAltSvc :: Maybe ByteString+    , settingsMaxBuilderResponseBufferSize :: Int+    , settingsConnectionCounter :: Maybe Counter+    , settingsServerState :: Maybe ServerState+    }++-- | Lifted 'Warp.defaultSettings'.+defaultSettings :: (IOE :> es) => Settings es+defaultSettings =+    Settings+        { settingsOnException = \_mReq e -> liftIO (settingsOnException Nothing e)+        , settingsOnExceptionResponse = liftResponse . settingsOnExceptionResponse+        , settingsOnOpen = liftIO . settingsOnOpen+        , settingsOnClose = liftIO . settingsOnClose+        , settingsBeforeMainLoop = liftIO settingsBeforeMainLoop+        , settingsFork = \inner ->+            withEffToIO (ConcUnlift Persistent Unlimited) \unlift ->+                void $ forkIOWithUnmask \unmask ->+                    unlift . inner $ liftIO . unmask . unlift+        , settingsAccept = liftIO . accept+        , settingsInstallShutdownHandler = \_close -> pure ()+        , settingsLogger = \req s ms -> liftIO (settingsLogger (unliftRequestNoBody req) s ms)+        , settingsServerPushLogger = \req p sz -> liftIO (settingsServerPushLogger (unliftRequestNoBody req) p sz)+        , ..+        }+  where+    WarpI.Settings{..} = Warp.defaultSettings++liftSettings :: (IOE :> es) => Warp.Settings -> Settings es+liftSettings WarpI.Settings{..} =+    Settings+        { settingsOnException = \_mReq -> liftIO . settingsOnException Nothing+        , settingsOnExceptionResponse = liftResponse . settingsOnExceptionResponse+        , settingsOnOpen = liftIO . settingsOnOpen+        , settingsOnClose = liftIO . settingsOnClose+        , settingsBeforeMainLoop = liftIO settingsBeforeMainLoop+        , settingsFork = \effInner ->+            withEffToIO (ConcUnlift Persistent Unlimited) \unlift ->+                settingsFork \ioUnmask ->+                    unlift . effInner $ liftIO . ioUnmask . unlift+        , settingsAccept = liftIO . settingsAccept+        , settingsInstallShutdownHandler = \closeEff ->+            withEffToIO SeqUnlift \unlift ->+                settingsInstallShutdownHandler (unlift closeEff)+        , settingsLogger = \req s ms -> liftIO (settingsLogger (unliftRequestNoBody req) s ms)+        , settingsServerPushLogger = ((liftIO .) .) . settingsServerPushLogger . unliftRequestNoBody+        , ..+        }++unliftSettings :: (IOE :> es) => (forall r. Eff es r -> IO r) -> Settings es -> Warp.Settings+unliftSettings unlift 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 \effUnmask -> liftIO . 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+        , ..+        }++-- | Lifted 'Warp.run'.+run :: (IOE :> es) => Port -> Application es -> Eff es ()+run port = runSettings $ defaultSettings{settingsPort = port}++-- | 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)++-- | 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)++-- | 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)++-- | Lifted 'Warp.setPort'.+setPort :: Port -> Settings es -> Settings es+setPort v s = s{settingsPort = v}++-- | Lifted 'Warp.setHost'.+setHost :: HostPreference -> Settings es -> Settings es+setHost v s = s{settingsHost = v}++-- | Lifted 'Warp.setOnException'.+setOnException+    :: (Maybe (Request es) -> SomeException -> Eff es ())+    -> Settings es+    -> Settings es+setOnException v s = s{settingsOnException = v}++-- | Lifted 'Warp.setOnExceptionResponse'.+setOnExceptionResponse+    :: (SomeException -> Response es)+    -> Settings es+    -> Settings es+setOnExceptionResponse v s = s{settingsOnExceptionResponse = v}++-- | Lifted 'Warp.setOnOpen'.+setOnOpen :: (SockAddr -> Eff es Bool) -> Settings es -> Settings es+setOnOpen v s = s{settingsOnOpen = v}++-- | Lifted 'Warp.setOnClose'.+setOnClose :: (SockAddr -> Eff es ()) -> Settings es -> Settings es+setOnClose v s = s{settingsOnClose = v}++-- | Lifted 'Warp.setTimeout'.+setTimeout :: Int -> Settings es -> Settings es+setTimeout v s = s{settingsTimeout = v}++-- | Lifted 'Warp.setManager'.+setManager :: Manager -> Settings es -> Settings es+setManager v s = s{settingsManager = Just v}++-- | Lifted 'Warp.setFdCacheDuration'.+setFdCacheDuration :: Int -> Settings es -> Settings es+setFdCacheDuration v s = s{settingsFdCacheDuration = v}++-- | Lifted 'Warp.setFileInfoCacheDuration'.+setFileInfoCacheDuration :: Int -> Settings es -> Settings es+setFileInfoCacheDuration v s = s{settingsFileInfoCacheDuration = v}++-- | Lifted 'Warp.setBeforeMainLoop'.+setBeforeMainLoop :: Eff es () -> Settings es -> Settings es+setBeforeMainLoop v s = s{settingsBeforeMainLoop = v}++-- | Lifted 'Warp.setNoParsePath'.+setNoParsePath :: Bool -> Settings es -> Settings es+setNoParsePath v s = s{settingsNoParsePath = v}++-- | Lifted 'Warp.setInstallShutdownHandler'.+setInstallShutdownHandler :: (Eff es () -> Eff es ()) -> Settings es -> Settings es+setInstallShutdownHandler v s = s{settingsInstallShutdownHandler = v}++-- | Lifted 'Warp.setServerName'.+setServerName :: ByteString -> Settings es -> Settings es+setServerName v s = s{settingsServerName = v}++-- | Lifted 'Warp.setMaximumBodyFlush'.+setMaximumBodyFlush :: Maybe Int -> Settings es -> Settings es+setMaximumBodyFlush v s = s{settingsMaximumBodyFlush = v}++-- | Lifted 'Warp.setFork'.+setFork+    :: (((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es ())+    -> Settings es+    -> Settings es+setFork v s = s{settingsFork = v}++-- | Lifted 'Warp.setAccept'.+setAccept+    :: (Socket -> Eff es (Socket, SockAddr))+    -> Settings es+    -> Settings es+setAccept v s = s{settingsAccept = v}++-- | Lifted 'Warp.setProxyProtocolNone'.+setProxyProtocolNone :: Settings es -> Settings es+setProxyProtocolNone s = s{settingsProxyProtocol = WarpI.ProxyProtocolNone}++-- | Lifted 'Warp.setProxyProtocolRequired'.+setProxyProtocolRequired :: Settings es -> Settings es+setProxyProtocolRequired s = s{settingsProxyProtocol = WarpI.ProxyProtocolRequired}++-- | Lifted 'Warp.setProxyProtocolOptional'.+setProxyProtocolOptional :: Settings es -> Settings es+setProxyProtocolOptional s = s{settingsProxyProtocol = WarpI.ProxyProtocolOptional}++-- | Lifted 'Warp.setSlowlorisSize'.+setSlowlorisSize :: Int -> Settings es -> Settings es+setSlowlorisSize v s = s{settingsSlowlorisSize = v}++-- | Lifted 'Warp.setHTTP2Disabled'.+setHTTP2Disabled :: Settings es -> Settings es+setHTTP2Disabled s = s{settingsHTTP2Enabled = False}++-- | Lifted 'Warp.setLogger'.+setLogger+    :: (Request es -> HTTP.Status -> Maybe Integer -> Eff es ())+    -> Settings es+    -> Settings es+setLogger v s = s{settingsLogger = v}++-- | Lifted 'Warp.setServerPushLogger'.+setServerPushLogger+    :: (Request es -> ByteString -> Integer -> Eff es ())+    -> Settings es+    -> Settings es+setServerPushLogger v s = s{settingsServerPushLogger = v}++-- | Lifted 'Warp.setGracefulShutdownTimeout'.+setGracefulShutdownTimeout :: Maybe Int -> Settings es -> Settings es+setGracefulShutdownTimeout v s = s{settingsGracefulShutdownTimeout = v}++-- | Lifted 'Warp.setGracefulCloseTimeout1'.+setGracefulCloseTimeout1 :: Int -> Settings es -> Settings es+setGracefulCloseTimeout1 v s = s{settingsGracefulCloseTimeout1 = v}++-- | Lifted 'Warp.setGracefulCloseTimeout2'.+setGracefulCloseTimeout2 :: Int -> Settings es -> Settings es+setGracefulCloseTimeout2 v s = s{settingsGracefulCloseTimeout2 = v}++-- | Lifted 'Warp.setMaxTotalHeaderLength'.+setMaxTotalHeaderLength :: Int -> Settings es -> Settings es+setMaxTotalHeaderLength v s = s{settingsMaxTotalHeaderLength = v}++-- | Lifted 'Warp.setAltSvc'.+setAltSvc :: ByteString -> Settings es -> Settings es+setAltSvc v s = s{settingsAltSvc = Just v}++-- | Lifted 'Warp.setMaxBuilderResponseBufferSize'.+setMaxBuilderResponseBufferSize :: Int -> Settings es -> Settings es+setMaxBuilderResponseBufferSize v s = s{settingsMaxBuilderResponseBufferSize = v}++-- | Lifted 'Warp.getPort'.+getPort :: Settings es -> Port+getPort = settingsPort++-- | Lifted 'Warp.getHost'.+getHost :: Settings es -> HostPreference+getHost = settingsHost++-- | Lifted 'Warp.getOnOpen'.+getOnOpen :: Settings es -> SockAddr -> Eff es Bool+getOnOpen = settingsOnOpen++-- | Lifted 'Warp.getOnClose'.+getOnClose :: Settings es -> SockAddr -> Eff es ()+getOnClose = settingsOnClose++-- | Lifted 'Warp.getOnException'.+getOnException :: Settings es -> Maybe (Request es) -> SomeException -> Eff es ()+getOnException = settingsOnException++-- | Lifted 'Warp.getGracefulShutdownTimeout'.+getGracefulShutdownTimeout :: Settings es -> Maybe Int+getGracefulShutdownTimeout = settingsGracefulShutdownTimeout++-- | Lifted 'Warp.getGracefulCloseTimeout1'.+getGracefulCloseTimeout1 :: Settings es -> Int+getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1++-- | Lifted 'Warp.getGracefulCloseTimeout2'.+getGracefulCloseTimeout2 :: Settings es -> Int+getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2++-- | Lifted 'Warp.getOpenConnectionCounter'.+getOpenConnectionCounter :: Settings es -> Maybe Counter+getOpenConnectionCounter = settingsConnectionCounter++-- | Lifted 'Warp.getServerState'.+getServerState :: Settings es -> Maybe ServerState+getServerState = settingsServerState++-- | Lifted 'Warp.makeSettingsAndServerState'.+makeSettingsAndServerState :: (IOE :> es) => Eff es (ServerState, Settings es)+makeSettingsAndServerState = liftIO $ second liftSettings <$> Warp.makeSettingsAndServerState++-- | Lifted 'Warp.currentOpenConnections'.+currentOpenConnections :: (IOE :> es) => ServerState -> Eff es Int+currentOpenConnections = liftIO . Warp.currentOpenConnections++-- | Lifted 'Warp.currentShuttingDownState'.+currentShuttingDownState :: (IOE :> es) => ServerState -> Eff es Bool+currentShuttingDownState = liftIO . Warp.currentShuttingDownState++-- | Lifted 'Warp.makeSettingsAndCounter'.+makeSettingsAndCounter :: (IOE :> es) => Eff es (Counter, Settings es)+makeSettingsAndCounter = liftIO $ second liftSettings <$> Warp.makeSettingsAndCounter++-- | Lifted 'Warp.defaultOnException'.+defaultOnException :: (IOE :> es) => Maybe (Request es) -> SomeException -> Eff es ()+defaultOnException = (liftIO .) . Warp.defaultOnException . fmap unliftRequestNoBody++-- | Lifted 'Warp.defaultOnExceptionResponse'.+defaultOnExceptionResponse :: (IOE :> es) => SomeException -> Response es+defaultOnExceptionResponse = liftResponse . Warp.defaultOnExceptionResponse++-- | Lifted 'Warp.exceptionResponseForDebug'.+exceptionResponseForDebug :: (IOE :> es) => SomeException -> Response es+exceptionResponseForDebug = liftResponse . Warp.exceptionResponseForDebug++-- | Lifted 'Warp.pauseTimeout'.+pauseTimeout :: (IOE :> es) => Request es -> Eff es ()+pauseTimeout = liftIO . Warp.pauseTimeout . unliftRequestNoBody++-- | Lifted 'Warp.getFileInfo'.+getFileInfo :: (IOE :> es) => Request es -> FilePath -> Eff es FileInfo+getFileInfo = (liftIO .) . Warp.getFileInfo . unliftRequestNoBody++-- | Lifted 'Warp.clientCertificate'.+clientCertificate :: Request es -> Maybe CertificateChain+clientCertificate = Warp.clientCertificate . unliftRequestNoBody++-- | 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)++-- | Lifted 'Warp.withApplicationSettings'.+withApplicationSettings+    :: (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+        Warp.withApplicationSettings+            (unliftSettings unlift 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)++-- | Lifted 'Warp.testWithApplicationSettings'.+testWithApplicationSettings+    :: (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+        Warp.testWithApplicationSettings+            (unliftSettings unlift settings)+            (pure (unliftApplication unlift app))+            (unlift . k)++-- | Lifted 'Warp.openFreePort'.+openFreePort :: (IOE :> es) => Eff es (Port, Socket)+openFreePort = liftIO Warp.openFreePort++-- | Lifted 'Warp.getHTTP2Data'.+getHTTP2Data :: (IOE :> es) => Request es -> Eff es (Maybe HTTP2Data)+getHTTP2Data = liftIO . Warp.getHTTP2Data . unliftRequestNoBody++-- | Lifted 'Warp.setHTTP2Data'.+setHTTP2Data :: (IOE :> es) => Request es -> Maybe HTTP2Data -> Eff es ()+setHTTP2Data = (liftIO .) . Warp.setHTTP2Data . unliftRequestNoBody++-- | Lifted 'Warp.modifyHTTP2Data'.+modifyHTTP2Data :: (IOE :> es) => Request es -> (Maybe HTTP2Data -> Maybe HTTP2Data) -> Eff es ()+modifyHTTP2Data = (liftIO .) . Warp.modifyHTTP2Data . unliftRequestNoBody

@@ -0,0 +1,43 @@+module Main where++import Data.ByteString.Lazy (LazyByteString)+import Effectful+import Effectful.Hspec+import Effectful.HttpClient+import Effectful.Wai hiding (Response, responseStatus)+import Effectful.Wai.Handler.Warp+import Network.HTTP.Types qualified as HTTP+import Prelude++post :: (HttpClient :> es) => LazyByteString -> Port -> Eff es (Response LazyByteString)+post body port = do+    req <- parseRequest $ "http://127.0.0.1:" <> show port <> "/hello"+    httpLbs+        req+            { method = "POST"+            , requestBody = RequestBodyLBS body+            , requestHeaders = [("Connection", "close")]+            }++main :: IO ()+main = runEff . runHttpClient . runHspec . describe "Warp" $ do+    it "serves a request over a real listener" do+        let app :: Application es+            app _req respond = respond $ responseLBS HTTP.ok200 [] "hello world"+        resp <- withApplication (pure app) (post mempty)+        responseStatus resp `shouldBe` HTTP.ok200++    it "round-trips a request body" do+        let app :: (IOE :> es) => Application es+            app req respond = do+                body <- strictRequestBody req+                respond $ responseLBS HTTP.ok200 [] body+        resp <- withApplication (pure app) (post "hello world")+        responseBody resp `shouldBe` "hello world"++    it "serves through testWithApplicationSettings" do+        let app :: Application es+            app _req respond = respond $ responseLBS HTTP.ok200 [] "hello world"+        (_counter, settings) <- makeSettingsAndCounter+        resp <- testWithApplicationSettings settings (pure app) (post mempty)+        responseStatus resp `shouldBe` HTTP.ok200

@@ -0,0 +1,76 @@+cabal-version: 3.0+name: warp-effectful+version: 1.0.0+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.++homepage: https://digital-autonomy.institute+license: EUPL-1.2+license-file: LICENCE+author: IDA+maintainer: IDA+bug-reports: https://issues.digital-autonomy.institute+category: Network+build-type: Simple+extra-source-files:+  CHANGELOG.md++common common+  default-language: Haskell2010+  ghc-options:+    -Weverything+    -Wno-unsafe+    -Wno-missing-safe-haskell-mode+    -Wno-missing-export-lists+    -Wno-missing-import-lists+    -Wno-missing-kind-signatures+    -Wno-all-missed-specialisations+    -Wno-missing-role-annotations++  default-extensions:+    BlockArguments+    DataKinds+    ExplicitNamespaces+    FlexibleContexts+    ImportQualifiedPost+    ImpredicativeTypes+    LambdaCase+    NoImplicitPrelude+    OverloadedStrings+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    TypeApplications+    TypeFamilies+    TypeOperators+    ViewPatterns++  build-depends:+    base >=4.10 && <5,+    bytestring >=0.12 && <0.13,+    effectful >=2.6 && <2.7,+    http-types >=0.12 && <0.13,+    wai-effectful >=1.0 && <1.1,++library+  import: common+  hs-source-dirs: src+  build-depends:+    crypton-x509 >=1.7 && <1.10,+    network >=3.2 && <3.3,+    time-manager >=0.2 && <0.4,+    warp >=3.4.13 && <3.5,++  exposed-modules:+    Effectful.Wai.Handler.Warp++test-suite test+  import: common+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:+    hspec-effectful >=1.0 && <1.2,+    http-client-effectful >=1.0 && <1.1,+    warp-effectful,