module WebGear.Types
(
Request
, remoteHost
, httpVersion
, isSecure
, requestMethod
, pathInfo
, queryString
, requestHeader
, requestHeaders
, requestBodyLength
, getRequestBodyChunk
, Response (..)
, responseHeader
, setResponseHeader
, waiResponse
, respond
, continue100
, switchingProtocols101
, ok200
, created201
, accepted202
, nonAuthoritative203
, noContent204
, resetContent205
, partialContent206
, multipleChoices300
, movedPermanently301
, found302
, seeOther303
, notModified304
, temporaryRedirect307
, permanentRedirect308
, badRequest400
, unauthorized401
, paymentRequired402
, forbidden403
, notFound404
, methodNotAllowed405
, notAcceptable406
, proxyAuthenticationRequired407
, requestTimeout408
, conflict409
, gone410
, lengthRequired411
, preconditionFailed412
, requestEntityTooLarge413
, requestURITooLong414
, unsupportedMediaType415
, requestedRangeNotSatisfiable416
, expectationFailed417
, imATeapot418
, unprocessableEntity422
, preconditionRequired428
, tooManyRequests429
, requestHeaderFieldsTooLarge431
, internalServerError500
, notImplemented501
, badGateway502
, serviceUnavailable503
, gatewayTimeout504
, httpVersionNotSupported505
, networkAuthenticationRequired511
, Handler'
, Handler
, Middleware'
, Middleware
, RequestMiddleware'
, RequestMiddleware
, ResponseMiddleware'
, ResponseMiddleware
, Router (..)
, MonadRouter (..)
, PathInfo (..)
, RouteError (..)
, transform
, runRoute
, toApplication
) where
import Control.Applicative (Alternative)
import Control.Arrow (Kleisli (..))
import Control.Monad (MonadPlus)
import Control.Monad.Except (ExceptT, MonadError, catchError, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State.Strict (MonadState, StateT, evalStateT)
import Data.ByteString (ByteString)
import Data.ByteString.Conversion.To (ToByteString, toByteString)
import Data.List (find)
import Data.Maybe (fromMaybe)
import Data.Semigroup (Semigroup (..), stimesIdempotent)
import Data.String (fromString)
import Data.Text (Text)
import Data.Version (showVersion)
import GHC.Exts (fromList)
import Network.Wai (Request, getRequestBodyChunk, httpVersion, isSecure, pathInfo, queryString,
remoteHost, requestBodyLength, requestHeaders, requestMethod)
import Paths_webgear_server (version)
import WebGear.Trait (Linked, link)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as HM
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
requestHeader :: HTTP.HeaderName -> Request -> Maybe ByteString
requestHeader h r = snd <$> find ((== h) . fst) (requestHeaders r)
data Response a = Response
{ responseStatus :: HTTP.Status
, responseHeaders :: HM.HashMap HTTP.HeaderName ByteString
, responseBody :: Maybe a
}
deriving stock (Eq, Ord, Show, Functor)
responseHeader :: HTTP.HeaderName -> Response a -> Maybe ByteString
responseHeader h = HM.lookup h . responseHeaders
setResponseHeader :: HTTP.HeaderName -> ByteString -> Response a -> Response a
setResponseHeader name val r = r { responseHeaders = HM.insert name val (responseHeaders r) }
waiResponse :: Response LBS.ByteString -> Wai.Response
waiResponse Response{..} = Wai.responseLBS
responseStatus
(HM.toList responseHeaders)
(fromMaybe "" responseBody)
respond :: HTTP.Status -> Maybe a -> Response a
respond s = Response s mempty
continue100 :: Response a
continue100 = respond HTTP.continue100 Nothing
switchingProtocols101 :: Response a
switchingProtocols101 = respond HTTP.switchingProtocols101 Nothing
ok200 :: a -> Response a
ok200 = respond HTTP.ok200 . Just
created201 :: a -> Response a
created201 = respond HTTP.created201 . Just
accepted202 :: a -> Response a
accepted202 = respond HTTP.accepted202 . Just
nonAuthoritative203 :: a -> Response a
nonAuthoritative203 = respond HTTP.nonAuthoritative203 . Just
noContent204 :: Response a
noContent204 = respond HTTP.noContent204 Nothing
resetContent205 :: Response a
resetContent205 = respond HTTP.resetContent205 Nothing
partialContent206 :: a -> Response a
partialContent206 = respond HTTP.partialContent206 . Just
multipleChoices300 :: a -> Response a
multipleChoices300 = respond HTTP.multipleChoices300 . Just
movedPermanently301 :: a -> Response a
movedPermanently301 = respond HTTP.movedPermanently301 . Just
found302 :: a -> Response a
found302 = respond HTTP.found302 . Just
seeOther303 :: a -> Response a
seeOther303 = respond HTTP.seeOther303 . Just
notModified304 :: Response a
notModified304 = respond HTTP.notModified304 Nothing
temporaryRedirect307 :: a -> Response a
temporaryRedirect307 = respond HTTP.temporaryRedirect307 . Just
permanentRedirect308 :: a -> Response a
permanentRedirect308 = respond HTTP.permanentRedirect308 . Just
badRequest400 :: a -> Response a
badRequest400 = respond HTTP.badRequest400 . Just
unauthorized401 :: a -> Response a
unauthorized401 = respond HTTP.unauthorized401 . Just
paymentRequired402 :: a -> Response a
paymentRequired402 = respond HTTP.paymentRequired402 . Just
forbidden403 :: a -> Response a
forbidden403 = respond HTTP.forbidden403 . Just
notFound404 :: Response a
notFound404 = respond HTTP.notFound404 Nothing
methodNotAllowed405 :: a -> Response a
methodNotAllowed405 = respond HTTP.methodNotAllowed405 . Just
notAcceptable406 :: a -> Response a
notAcceptable406 = respond HTTP.notAcceptable406 . Just
proxyAuthenticationRequired407 :: a -> Response a
proxyAuthenticationRequired407 = respond HTTP.proxyAuthenticationRequired407 . Just
requestTimeout408 :: a -> Response a
requestTimeout408 = respond HTTP.requestTimeout408 . Just
conflict409 :: a -> Response a
conflict409 = respond HTTP.conflict409 . Just
gone410 :: a -> Response a
gone410 = respond HTTP.gone410 . Just
lengthRequired411 :: a -> Response a
lengthRequired411 = respond HTTP.lengthRequired411 . Just
preconditionFailed412 :: a -> Response a
preconditionFailed412 = respond HTTP.preconditionFailed412 . Just
requestEntityTooLarge413 :: a -> Response a
requestEntityTooLarge413 = respond HTTP.requestEntityTooLarge413 . Just
requestURITooLong414 :: a -> Response a
requestURITooLong414 = respond HTTP.requestURITooLong414 . Just
unsupportedMediaType415 :: a -> Response a
unsupportedMediaType415 = respond HTTP.unsupportedMediaType415 . Just
requestedRangeNotSatisfiable416 :: a -> Response a
requestedRangeNotSatisfiable416 = respond HTTP.requestedRangeNotSatisfiable416 . Just
expectationFailed417 :: a -> Response a
expectationFailed417 = respond HTTP.expectationFailed417 . Just
imATeapot418 :: a -> Response a
imATeapot418 = respond HTTP.imATeapot418 . Just
unprocessableEntity422 :: a -> Response a
unprocessableEntity422 = respond HTTP.unprocessableEntity422 . Just
preconditionRequired428 :: a -> Response a
preconditionRequired428 = respond HTTP.preconditionRequired428 . Just
tooManyRequests429 :: a -> Response a
tooManyRequests429 = respond HTTP.tooManyRequests429 . Just
requestHeaderFieldsTooLarge431 :: a -> Response a
requestHeaderFieldsTooLarge431 = respond HTTP.requestHeaderFieldsTooLarge431 . Just
internalServerError500 :: a -> Response a
internalServerError500 = respond HTTP.internalServerError500 . Just
notImplemented501 :: a -> Response a
notImplemented501 = respond HTTP.notImplemented501 . Just
badGateway502 :: a -> Response a
badGateway502 = respond HTTP.badGateway502 . Just
serviceUnavailable503 :: a -> Response a
serviceUnavailable503 = respond HTTP.serviceUnavailable503 . Just
gatewayTimeout504 :: a -> Response a
gatewayTimeout504 = respond HTTP.gatewayTimeout504 . Just
httpVersionNotSupported505 :: a -> Response a
httpVersionNotSupported505 = respond HTTP.httpVersionNotSupported505 . Just
networkAuthenticationRequired511 :: a -> Response a
networkAuthenticationRequired511 = respond HTTP.networkAuthenticationRequired511 . Just
type Handler' m req a = Kleisli m (Linked req Request) (Response a)
type Handler req a = Handler' Router req a
type Middleware' m req req' a' a = Handler' m req' a' -> Handler' m req a
type Middleware req req' a' a = Middleware' Router req req' a' a
type RequestMiddleware' m req req' a = Middleware' m req req' a a
type RequestMiddleware req req' a = RequestMiddleware' Router req req' a
type ResponseMiddleware' m req a' a = Middleware' m req req a' a
type ResponseMiddleware req a' a = ResponseMiddleware' Router req a' a
transform :: (forall x. m x -> n x) -> Handler' m req a -> Handler' n req a
transform f (Kleisli mf) = Kleisli $ f . mf
newtype PathInfo = PathInfo [Text]
data RouteError = RouteMismatch
| ErrorResponse (Response LBS.ByteString)
deriving (Eq, Ord, Show)
instance Semigroup RouteError where
RouteMismatch <> e = e
e <> _ = e
stimes :: Integral b => b -> RouteError -> RouteError
stimes = stimesIdempotent
instance Monoid RouteError where
mempty = RouteMismatch
newtype Router a = Router
{ unRouter :: StateT PathInfo (ExceptT RouteError IO) a }
deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus
, MonadError RouteError
, MonadState PathInfo
, MonadIO
)
class (MonadState PathInfo m, Alternative m, MonadPlus m) => MonadRouter m where
rejectRoute :: m a
errorResponse :: Response LBS.ByteString -> m a
catchErrorResponse :: m a -> (Response LBS.ByteString -> m a) -> m a
instance MonadRouter Router where
rejectRoute :: Router a
rejectRoute = throwError RouteMismatch
errorResponse :: Response LBS.ByteString -> Router a
errorResponse = throwError . ErrorResponse
catchErrorResponse :: Router a -> (Response LBS.ByteString -> Router a) -> Router a
catchErrorResponse action handle = action `catchError` f
where
f RouteMismatch = rejectRoute
f (ErrorResponse res) = handle res
runRoute :: ToByteString a => Handler '[] a -> (Wai.Request -> IO Wai.Response)
runRoute route req = waiResponse . addServerHeader . either routeErrorToResponse id <$> runRouter
where
runRouter :: IO (Either RouteError (Response LBS.ByteString))
runRouter = fmap (fmap (fmap toByteString))
$ runExceptT
$ flip evalStateT (PathInfo $ pathInfo req)
$ unRouter
$ runKleisli route
$ link req
routeErrorToResponse :: RouteError -> Response LBS.ByteString
routeErrorToResponse RouteMismatch = notFound404
routeErrorToResponse (ErrorResponse r) = r
addServerHeader :: Response LBS.ByteString -> Response LBS.ByteString
addServerHeader r = r { responseHeaders = responseHeaders r <> fromList [serverHeader] }
serverHeader :: HTTP.Header
serverHeader = (HTTP.hServer, fromString $ "WebGear/" ++ showVersion version)
toApplication :: ToByteString a => Handler '[] a -> Wai.Application
toApplication route request next = runRoute route request >>= next