{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RankNTypes #-}
module Web.Porpoise
(
Server(..)
, toApplication
, liftS
, serverIO
, Profunctor(..)
, Category(..)
, MonadUnliftIO(..)
, ResponseReceived
, Application
, Request
, requestMethod
, httpVersion
, rawPathInfo
, rawQueryString
, requestHeaders
, isSecure
, remoteHost
, pathInfo
, queryString
, getRequestBodyChunk
, vault
, requestBodyLength
, requestHeaderHost
, requestHeaderRange
, requestHeaderReferer
, requestHeaderUserAgent
, strictRequestBody
, lazyRequestBody
, RequestBodyLength(..)
, Response
, FilePart(..)
, responseLBS
, responseStream
, responseRaw
, responseBuilder
, responseFile
, StreamingBody
, Status
, mkStatus
, Header
, HeaderName
, ResponseHeaders
, RequestHeaders
, hAccept
, hAcceptCharset
, hAcceptEncoding
, hAcceptLanguage
, hAcceptRanges
, hAge
, hAllow
, hAuthorization
, hCacheControl
, hConnection
, hContentEncoding
, hContentLanguage
, hContentLocation
, hContentMD5
, hContentRange
, hContentType
, hDate
, hETag
, hExpect
, hExpires
, hFrom
, hHost
, hIfMatch
, hIfModifiedSince
, hIfNoneMatch
, hIfRange
, hIfUnmodifiedSince
, hLastModified
, hLocation
, hMaxForwards
, hOrigin
, hPragma
, hPrefer
, hPreferenceApplied
, hProxyAuthenticate
, hRange
, hReferer
, hRetryAfter
, hServer
, hTE
, hTrailer
, hTransferEncoding
, hUpgrade
, hUserAgent
, hVary
, hVia
, hWWWAuthenticate
, hWarning
, hContentDisposition
, hMIMEVersion
, hCookie
, hSetCookie
, ByteRange(..)
, renderByteRangeBuilder
, renderByteRange
, ByteRanges
, renderByteRangesBuilder
, parseByteRanges
, HttpVersion(..)
, http09
, http10
, http11
, http20
, Method
, methodGet
, methodPost
, methodHead
, methodPut
, methodDelete
, methodTrace
, methodConnect
, methodOptions
, methodPatch
, StdMethod(..)
, parseMethod
, renderMethod
, renderStdMethod
, QueryItem
, Query
, urlEncode
, urlDecode
, urlEncodeBuilder
, extractPath
, decodePath
, encodePath
, SockAddr
, Vault
) where
import Prelude hiding ((.), id)
import Data.Coerce (coerce)
import Control.Arrow (Kleisli(Kleisli))
import Data.Profunctor (Profunctor(..))
import Control.Monad.Fail (MonadFail)
import Control.Monad.Reader (MonadReader, ReaderT(ReaderT))
import Control.Monad.Cont (MonadCont, ContT(ContT))
import Control.Category (Category((.), id))
import Network.Wai
import Network.Wai.Internal (ResponseReceived(ResponseReceived))
import UnliftIO (MonadIO(liftIO), MonadUnliftIO(withRunInIO))
import Network.HTTP.Types.Header
import Network.HTTP.Types.Version
import Network.HTTP.Types.Method
import Network.HTTP.Types.URI
import Network.HTTP.Types.Status
import Data.Vault.Lazy (Vault)
import Network.Socket (SockAddr)
newtype Server m request response = Server
{ unServer :: request -> (response -> m ResponseReceived) -> m ResponseReceived }
deriving (Functor, Applicative, Monad, MonadIO, MonadFail, MonadCont)
via ReaderT request (ContT ResponseReceived m)
askRequest :: Monad m => Server m request request
askRequest = id
instance Functor m => Profunctor (Server m) where
dimap f g (Server h) = Server \request respond -> h (f request) (respond . g)
instance Monad m => Category (Server m) where
Server a . Server b = coerce $ Kleisli (fmap ContT a) . Kleisli (fmap ContT b)
id :: forall a. Server m a a
id = Server \request respond -> respond request
{-# INLINE toApplication #-}
toApplication :: Server IO Request Response -> Application
toApplication = unServer
{-# INLINE liftS #-}
liftS :: Monad m => m response -> Server m request response
liftS r = Server $ const (r >>=)
{-# INLINE serverIO #-}
serverIO :: MonadUnliftIO m => m (Server m request response -> Server IO request response)
serverIO =
withRunInIO
\runner -> pure
\(Server f) -> Server
\request respond -> runner (f request (liftIO . respond))