diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Effectful/Wai/Handler/Warp.hs b/src/Effectful/Wai/Handler/Warp.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Wai/Handler/Warp.hs @@ -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 . +-- +-- = 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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/warp-effectful.cabal b/warp-effectful.cabal new file mode 100644 --- /dev/null +++ b/warp-effectful.cabal @@ -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 @@ library for the @@ 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,