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 :: forall es. (IOE :> es) => Wai.Response -> Response es
liftResponse (Wai.ResponseFile s h fp part) = ResponseFile s h fp part
liftResponse (Wai.ResponseBuilder s h b) = ResponseBuilder s h b
liftResponse (Wai.ResponseStream s h body) = ResponseStream s h (liftStreamingBody body)
liftResponse (Wai.ResponseRaw raw res) = ResponseRaw liftRaw (liftResponse res)
  where
    liftRaw :: Eff es ByteString -> (ByteString -> Eff es ()) -> Eff es ()
    liftRaw recv send = withRunInIO \unlift -> raw (unlift recv) (unlift . send)

unliftResponse
    :: forall es
     . (IOE :> es)
    => (forall r. Eff es r -> IO r)
    -> Response es
    -> Wai.Response
unliftResponse _ (ResponseFile s h fp part) = Wai.ResponseFile s h fp part
unliftResponse _ (ResponseBuilder s h b) = Wai.ResponseBuilder s h b
unliftResponse unlift (ResponseStream s h body) = Wai.ResponseStream s h (unliftStreamingBody unlift body)
unliftResponse unlift (ResponseRaw raw res) = Wai.ResponseRaw unliftRaw (unliftResponse unlift res)
  where
    unliftRaw :: IO ByteString -> (ByteString -> IO ()) -> IO ()
    unliftRaw recv send = unlift $ raw (liftIO recv) (liftIO . send)

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