Wai.hs

{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -Wno-deprecations #-}

-- |
-- Module      : Effectful.Wai
-- Copyright   : (c) 2026 Institute for Digital Autonomy
-- License     : EUPL-1.2
-- Maintainer  : IDA
--
-- Effectful bindings for the <http://hackage.haskell.org/package/wai wai 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 <http://hackage.haskell.org/package/warp-effectful warp-efectful>.
--
-- > {-# 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
    ( -- * Types
      Application
    , Middleware
    , ResponseReceived

      -- * Request
    , Request
    , defaultRequest
    , RequestBodyLength (..)

      -- ** Request accessors
    , requestMethod
    , httpVersion
    , rawPathInfo
    , rawQueryString
    , requestHeaders
    , isSecure
    , remoteHost
    , pathInfo
    , queryString
    , getRequestBodyChunk
    , requestBody
    , vault
    , requestBodyLength
    , requestHeaderHost
    , requestHeaderRange
    , requestHeaderReferer
    , requestHeaderUserAgent
      -- $streamingRequestBodies
    , strictRequestBody
    , consumeRequestBodyStrict
    , lazyRequestBody
    , consumeRequestBodyLazy

      -- ** Request modifiers
    , setRequestBodyChunks
    , mapRequestHeaders

      -- * Response
    , Response
    , StreamingBody
    , FilePart (..)

      -- ** Response composers
    , responseFile
    , responseBuilder
    , responseLBS
    , responseStream
    , responseRaw

      -- ** Response accessors
    , responseStatus
    , responseHeaders

      -- ** Response modifiers
    , responseToStream
    , mapResponseHeaders
    , mapResponseStatus

      -- * Middleware composition
    , ifRequest
    , modifyRequest
    , modifyResponse

      -- * Lifting and unlifting
    , liftApplication
    , unliftApplication
    , liftMiddleware
    , unliftMiddleware
    , liftRequest
    , unliftRequest
    , unliftRequestNoBody
    , liftResponse
    , unliftResponse
    , liftStream
    , liftStreamingBody
    , unliftStreamingBody
    )
where

import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder, lazyByteString)
import Data.ByteString.Lazy (LazyByteString)
import Data.Text (Text)
import Data.Vault.Lazy (Vault)
import Effectful
import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders, ResponseHeaders, Status)
import Network.Socket (SockAddr)
import Network.Wai (FilePart (..), RequestBodyLength (..), ResponseReceived)
import Network.Wai qualified as Wai
import Network.Wai.Internal qualified as Wai
import Prelude

-- | Lifted 'Wai.Application'.
type Application es =
    Request es
    -> (Response es -> Eff es ResponseReceived)
    -> Eff es ResponseReceived

liftApplication :: (IOE :> es) => Wai.Application -> Application es
liftApplication app req respondEff =
    withSeqEffToIO \unlift ->
        app (unliftRequest unlift req) (unlift . respondEff . liftResponse)

unliftApplication
    :: (IOE :> es)
    => (forall r. Eff es r -> IO r)
    -> Application es
    -> Wai.Application
unliftApplication unlift app waiReq waiRespond =
    unlift . app (liftRequest waiReq) $ liftIO . waiRespond . unliftResponse unlift

-- | Lifted 'Wai.Middleware'.
type Middleware es = Application es -> Application es

liftMiddleware :: (IOE :> es) => Wai.Middleware -> Middleware es
liftMiddleware middleware app req resp =
    withSeqEffToIO \unlift ->
        unlift $ (liftApplication . middleware . unliftApplication unlift $ app) req resp

unliftMiddleware :: (IOE :> es) => (forall r. Eff es r -> IO r) -> Middleware es -> Wai.Middleware
unliftMiddleware unlift middleware = unliftApplication unlift . middleware . liftApplication

-- | Lifted 'Wai.Request'.
data Request es = Request
    { requestMethod :: Method
    , httpVersion :: HttpVersion
    , rawPathInfo :: ByteString
    , rawQueryString :: ByteString
    , requestHeaders :: RequestHeaders
    , isSecure :: Bool
    , remoteHost :: Network.Socket.SockAddr
    , pathInfo :: [Text]
    , queryString :: Query
    , requestBody :: Eff es ByteString
    , vault :: Vault
    , requestBodyLength :: RequestBodyLength
    , requestHeaderHost :: Maybe ByteString
    , requestHeaderRange :: Maybe ByteString
    , requestHeaderReferer :: Maybe ByteString
    , requestHeaderUserAgent :: Maybe ByteString
    }

liftRequest :: (IOE :> es) => Wai.Request -> Request es
liftRequest Wai.Request{..} =
    Request
        { requestBody = liftIO requestBody
        , ..
        }

unliftRequest :: (forall r. Eff es r -> IO r) -> Request es -> Wai.Request
unliftRequest unlift Request{..} =
    Wai.Request
        { Wai.requestBody = unlift requestBody
        , ..
        }

unliftRequestNoBody :: Request es -> Wai.Request
unliftRequestNoBody Request{..} =
    Wai.Request
        { requestBody = pure mempty
        , ..
        }

-- | Lifted 'Wai.defaultRequest'.
defaultRequest :: (IOE :> es) => Request es
defaultRequest = liftRequest Wai.defaultRequest

-- | Lifted 'Wai.getRequestBodyChunk'.
getRequestBodyChunk :: Request es -> Eff es ByteString
getRequestBodyChunk = requestBody

-- | Lifted 'Wai.strictRequestBody'.
strictRequestBody :: (IOE :> es) => Request es -> Eff es LazyByteString
strictRequestBody = withSeqEffToIO . (Wai.strictRequestBody .) . flip unliftRequest

-- | Lifted 'Wai.consumeRequestBodyStrict'.
consumeRequestBodyStrict :: (IOE :> es) => Request es -> Eff es LazyByteString
consumeRequestBodyStrict = strictRequestBody

-- | Lifted 'Wai.lazyRequestBody'.
lazyRequestBody :: (IOE :> es) => Request es -> Eff es LazyByteString
lazyRequestBody = withSeqEffToIO . (Wai.lazyRequestBody .) . flip unliftRequest

-- | Lifted 'Wai.consumeRequestBodyLazy'.
consumeRequestBodyLazy :: (IOE :> es) => Request es -> Eff es LazyByteString
consumeRequestBodyLazy = lazyRequestBody

-- | Lifted 'Wai.setRequestBodyChunks'.
setRequestBodyChunks :: Eff es ByteString -> Request es -> Request es
setRequestBodyChunks body req = req{requestBody = body}

-- | Lifted 'Wai.mapRequestHeaders'.
mapRequestHeaders
    :: (RequestHeaders -> RequestHeaders)
    -> Request es
    -> Request es
mapRequestHeaders f req = req{requestHeaders = f (requestHeaders req)}

-- | Lifted 'Wai.Response'.
data Response es
    = ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)
    | ResponseBuilder Status ResponseHeaders Builder
    | ResponseStream Status ResponseHeaders (StreamingBody es)
    | ResponseRaw (Eff es ByteString -> (ByteString -> Eff es ()) -> Eff es ()) (Response es)

liftResponse :: (IOE :> es) => Wai.Response -> Response es
liftResponse res = ResponseStream status headers streamingBody
  where
    (status, headers, withStream) = Wai.responseToStream res
    streamingBody send flush = liftStream withStream \body -> body send flush

unliftResponse :: (IOE :> es) => (forall r. Eff es r -> IO r) -> Response es -> Wai.Response
unliftResponse unlift res =
    Wai.responseStream status headers $
        unliftStreamingBody unlift \send flush ->
            withStream \body -> body send flush
  where
    (status, headers, withStream) = responseToStream res

-- | Lifted 'Wai.StreamingBody'.
type StreamingBody es = (Builder -> Eff es ()) -> Eff es () -> Eff es ()

liftStreamingBody :: (IOE :> es) => Wai.StreamingBody -> StreamingBody es
liftStreamingBody body send flush = withRunInIO \unlift -> body (unlift . send) (unlift flush)

unliftStreamingBody
    :: (IOE :> es)
    => (forall r. Eff es r -> IO r)
    -> StreamingBody es
    -> Wai.StreamingBody
unliftStreamingBody unlift body send flush = unlift $ body (liftIO . send) (liftIO flush)

-- | Lifted 'Wai.responseFile'.
responseFile
    :: Status
    -> ResponseHeaders
    -> FilePath
    -> Maybe FilePart
    -> Response es
responseFile = ResponseFile

-- | Lifted 'Wai.responseBuilder'.
responseBuilder :: Status -> ResponseHeaders -> Builder -> Response es
responseBuilder = ResponseBuilder

-- | Lifted 'Wai.responseLBS'.
responseLBS :: Status -> ResponseHeaders -> LazyByteString -> Response es
responseLBS s h = ResponseBuilder s h . lazyByteString

-- | Lifted 'Wai.responseStream'.
responseStream
    :: Status
    -> ResponseHeaders
    -> StreamingBody es
    -> Response es
responseStream = ResponseStream

-- | Lifted 'Wai.responseRaw'.
responseRaw
    :: (Eff es ByteString -> (ByteString -> Eff es ()) -> Eff es ())
    -> Response es
    -> Response es
responseRaw = ResponseRaw

-- | Lifted 'Wai.responseStatus'.
responseStatus :: Response es -> Status
responseStatus (ResponseFile s _ _ _) = s
responseStatus (ResponseBuilder s _ _) = s
responseStatus (ResponseStream s _ _) = s
responseStatus (ResponseRaw _ res) = responseStatus res

-- | Lifted 'Wai.responseHeaders'.
responseHeaders :: Response es -> ResponseHeaders
responseHeaders (ResponseFile _ hs _ _) = hs
responseHeaders (ResponseBuilder _ hs _) = hs
responseHeaders (ResponseStream _ hs _) = hs
responseHeaders (ResponseRaw _ res) = responseHeaders res

-- | Lifted 'Wai.responseToStream'.
responseToStream
    :: (IOE :> es)
    => Response es
    -> (Status, ResponseHeaders, (StreamingBody es -> Eff es a) -> Eff es a)
responseToStream (ResponseStream s h b) = (s, h, ($ b))
responseToStream (ResponseFile s h fp part) = (s, h, liftStream stream)
  where
    (_s, _h, stream) = Wai.responseToStream $ Wai.ResponseFile s h fp part
responseToStream (ResponseBuilder s h b) = (s, h, liftStream stream)
  where
    (_s, _h, stream) = Wai.responseToStream $ Wai.ResponseBuilder s h b
responseToStream (ResponseRaw _ res) = responseToStream res

liftStream
    :: (IOE :> es)
    => ((Wai.StreamingBody -> IO a) -> IO a)
    -> (StreamingBody es -> Eff es a)
    -> Eff es a
liftStream f k = withRunInIO \unlift -> f $ unlift . k . liftStreamingBody

-- | Lifted 'Wai.mapResponseHeaders'.
mapResponseHeaders
    :: (ResponseHeaders -> ResponseHeaders)
    -> Response es
    -> Response es
mapResponseHeaders f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2
mapResponseHeaders f (ResponseBuilder s h b) = ResponseBuilder s (f h) b
mapResponseHeaders f (ResponseStream s h b) = ResponseStream s (f h) b
mapResponseHeaders _ r@(ResponseRaw _ _) = r

-- | Lifted 'Wai.mapResponseStatus'.
mapResponseStatus :: (Status -> Status) -> Response es -> Response es
mapResponseStatus f (ResponseFile s h b1 b2) = ResponseFile (f s) h b1 b2
mapResponseStatus f (ResponseBuilder s h b) = ResponseBuilder (f s) h b
mapResponseStatus f (ResponseStream s h b) = ResponseStream (f s) h b
mapResponseStatus _ r@(ResponseRaw _ _) = r

-- | Lifted 'Wai.modifyRequest'.
modifyRequest :: (Request es -> Request es) -> Middleware es
modifyRequest f app = app . f

-- | Lifted 'Wai.modifyResponse'.
modifyResponse :: (Response es -> Response es) -> Middleware es
modifyResponse f app req respond = app req $ respond . f

-- | Lifted 'Wai.ifRequest'.
ifRequest :: (Request es -> Bool) -> Middleware es -> Middleware es
ifRequest rpred middle app req
    | rpred req = middle app req
    | otherwise = app req