Something went wrong. Try again.
A Haskell Webserver Template
Something went wrong. Try again.
4.0 kB · 131 lines
Haskell
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132module Webserver.Data.Response ( ResponseBody (..), Response (..), response, withHeader, withHeaders, withBody, withJsonBody, withFileBody, toWaiResponse, ok, created, badRequest, unauthorized, forbidden, notFound, methodNotAllowed, requestTimeout, payloadTooLarge, unsupportedMediaType, imATeapot, tooManyRequests, internalServerError, respondBodyError,)where
----------------------------------------------------------------------------------------------------
import qualified Data.Aeson as Aesonimport qualified Network.HTTP.Types as Httpimport qualified Network.Wai as Waiimport Webserver.Data.BodyError (BodyError (..))
----------------------------------------------------------------------------------------------------
-- | The body of a 'Response', either a lazy bytestring or a file pathdata ResponseBody = LBSBody !Json | FileBody !String
data Response = Response { status :: !Http.Status , headers :: !(List Http.Header) , body :: !ResponseBody }
-- | Construct a 'Response' from a status code with no headers and an empty bodyresponse :: Http.Status -> Responseresponse status_ = Response { status = status_ , headers = [] , body = LBSBody "" }
-- | Add a single header to a 'Response'withHeader :: Http.Header -> Response -> ResponsewithHeader h r = r {headers = h : r.headers}
-- | Add multiple headers to a 'Response'withHeaders :: List Http.Header -> Response -> ResponsewithHeaders hs r = r {headers = hs <> r.headers}
-- | Set the raw body of a 'Response'withBody :: Json -> Response -> ResponsewithBody b r = r {body = LBSBody b}
-- | Set the body of a 'Response' by JSON-encoding a valuewithJsonBody :: (Aeson.ToJSON a) => a -> Response -> ResponsewithJsonBody val r = r {body = LBSBody (Aeson.encode val)}
-- | Set the body of a 'Response' to a file pathwithFileBody :: String -> Response -> ResponsewithFileBody path r = r {body = FileBody path}
-- | Convert a 'Response' into a WAI 'Wai.Response'toWaiResponse :: Response -> Wai.ResponsetoWaiResponse r = case r.body of LBSBody lbs -> Wai.responseLBS r.status r.headers lbs FileBody path -> Wai.responseFile r.status r.headers path Nothing
----------------------------------------------------------------------------------------------------
ok :: Responseok = response Http.ok200 |> withBody "Ok"
created :: Responsecreated = response Http.created201 |> withBody "Created"
badRequest :: ResponsebadRequest = response Http.badRequest400 |> withBody "Bad Request"
unauthorized :: Responseunauthorized = response Http.unauthorized401 |> withBody "Not Authorized"
forbidden :: Responseforbidden = response Http.forbidden403 |> withBody "Forbidden"
notFound :: ResponsenotFound = response Http.notFound404 |> withBody "Not Found"
methodNotAllowed :: ResponsemethodNotAllowed = response Http.methodNotAllowed405 |> withBody "Method Not Allowed"
requestTimeout :: ResponserequestTimeout = response Http.requestTimeout408 |> withBody "Request Timeout"
payloadTooLarge :: ResponsepayloadTooLarge = response Http.requestEntityTooLarge413 |> withBody "Payload Too Large"
unsupportedMediaType :: ResponseunsupportedMediaType = response Http.unsupportedMediaType415 |> withBody "Unsupported Media Type"
imATeapot :: ResponseimATeapot = response Http.imATeapot418 |> withBody "I'm a Teapot"
tooManyRequests :: ResponsetooManyRequests = response Http.tooManyRequests429 |> withBody "Too Many Requests"
internalServerError :: ResponseinternalServerError = response Http.internalServerError500 |> withBody "Internal Server Error"
----------------------------------------------------------------------------------------------------
-- | Map a 'BodyError' to the appropriate 'Response'respondBodyError :: BodyError -> ResponserespondBodyError = \case UnsupportedContentType -> unsupportedMediaType BodyTooLarge -> payloadTooLarge DecodeFailed -> badRequest