warp-effectful-1.0.0: src/Effectful/Wai/Handler/Warp.hs

{-# 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