diff --git a/src/Serv/Internal/Header.hs b/src/Serv/Internal/Header.hs index 726f994..f7e0ff0 100644 --- a/src/Serv/Internal/Header.hs +++ b/src/Serv/Internal/Header.hs @@ -14,13 +14,11 @@ module Serv.Internal.Header where -import qualified Data.CaseInsensitive as CI -import Data.Singletons +import qualified Data.CaseInsensitive as CI import Data.Singletons.TH +import Data.Singletons.TypeLits import Data.String -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.TypeLits +import Data.Text (Text) -- | The variant (name and meaning) of a HTTP header. -- @@ -510,9 +508,6 @@ type XForwardedFor = 'XForwardedFor type XForwardedHost = 'XForwardedHost type XForwardedProto = 'XForwardedProto -headerType :: forall s (h :: HeaderType Symbol) . IsString s => Sing h -> HeaderType s -headerType = fmap fromString . fromSing - standardHeaders :: [HeaderType a] standardHeaders = [ CacheControl @@ -583,76 +578,76 @@ standardHeaders = , WWWAuthenticate ] -headerName :: IsString s => HeaderType Text -> s +headerName :: forall s (h :: HeaderType Symbol) . IsString s => Sing h -> s headerName h = case h of - CustomHeader name -> fromString (Text.unpack name) - Accept -> "Accept" - AcceptCharset -> "Accept-Charset" - AcceptEncoding -> "Accept-Encoding" - AcceptLanguage -> "Accept-Language" - AcceptPatch -> "Accept-Patch" - AcceptRanges -> "Accept-Ranges" - AccessControlAllowCredentials -> "Access-Control-Allow-Credentials" - AccessControlAllowHeaders -> "Access-Control-Allow-Headers" - AccessControlAllowMethods -> "Access-Control-Allow-Methods" - AccessControlAllowOrigin -> "Access-Control-Allow-Origin" - AccessControlExposeHeaders -> "Access-Control-Expose-Headers" - AccessControlMaxAge -> "Access-Control-Max-Age" - AccessControlRequestHeaders -> "Access-Control-Request-Headers" - AccessControlRequestMethod -> "Access-Control-Request-Method" - Age -> "Age" - Allow -> "Allow" - Authorization -> "Authorization" - CacheControl -> "Cache-Control" - Connection -> "Connection" - ContentDisposition -> "Content-Disposition" - ContentEncoding -> "Content-Encoding" - ContentLanguage -> "Content-Language" - ContentLength -> "Content-Length" - ContentLocation -> "Content-Location" - ContentRange -> "Content-Range" - ContentSecurityPolicy -> "Content-Security-Policy" - ContentType -> "Content-Type" - Cookie -> "Cookie" - Date -> "Date" - ETag -> "ETag" - Expect -> "Expect" - Expires -> "Expires" - From -> "From" - Host -> "Host" - IfMatch -> "If-Match" - IfModifiedSince -> "If-Modified-Since" - IfNoneMatch -> "If-None-Match" - IfRange -> "If-Range" - IfUnmodifiedSince -> "If-Unmodified-Since" - LastModified -> "Last-Modified" - Link -> "Link" - Location -> "Location" - MaxForwards -> "Max-Forwards" - Origin -> "Origin" - Pragma -> "Pragma" - ProxyAuthenticate -> "Proxy-Authenticate" - ProxyAuthorization -> "Proxy-Authorization" - PublicKeyPins -> "Public-Key-Pins" - Range -> "Range" - Referer -> "Referer" - RetryAfter -> "Retry-After" - SetCookie -> "Set-Cookie" - StrictTransportSecurity -> "Strict-Transport-Security" - TE -> "TE" - Trailer -> "Trailer" - TransferEncoding -> "Transfer-Encoding" - Upgrade -> "Upgrade" - UserAgent -> "User-Agent" - Vary -> "Vary" - Via -> "Via" - WWWAuthenticate -> "WWW-Authenticate" - Warning -> "Warning" - XCsrfToken -> "X-Csrf-Token" - XForwardedFor -> "X-Forwarded-For" - XForwardedHost -> "X-Forwarded-Host" - XForwardedProto -> "X-Forwarded-Proto" + SCustomHeader name -> fromString (withKnownSymbol name (symbolVal name)) + SAccept -> "Accept" + SAcceptCharset -> "Accept-Charset" + SAcceptEncoding -> "Accept-Encoding" + SAcceptLanguage -> "Accept-Language" + SAcceptPatch -> "Accept-Patch" + SAcceptRanges -> "Accept-Ranges" + SAccessControlAllowCredentials -> "Access-Control-Allow-Credentials" + SAccessControlAllowHeaders -> "Access-Control-Allow-Headers" + SAccessControlAllowMethods -> "Access-Control-Allow-Methods" + SAccessControlAllowOrigin -> "Access-Control-Allow-Origin" + SAccessControlExposeHeaders -> "Access-Control-Expose-Headers" + SAccessControlMaxAge -> "Access-Control-Max-Age" + SAccessControlRequestHeaders -> "Access-Control-Request-Headers" + SAccessControlRequestMethod -> "Access-Control-Request-Method" + SAge -> "Age" + SAllow -> "Allow" + SAuthorization -> "Authorization" + SCacheControl -> "Cache-Control" + SConnection -> "Connection" + SContentDisposition -> "Content-Disposition" + SContentEncoding -> "Content-Encoding" + SContentLanguage -> "Content-Language" + SContentLength -> "Content-Length" + SContentLocation -> "Content-Location" + SContentRange -> "Content-Range" + SContentSecurityPolicy -> "Content-Security-Policy" + SContentType -> "Content-Type" + SCookie -> "Cookie" + SDate -> "Date" + SETag -> "ETag" + SExpect -> "Expect" + SExpires -> "Expires" + SFrom -> "From" + SHost -> "Host" + SIfMatch -> "If-Match" + SIfModifiedSince -> "If-Modified-Since" + SIfNoneMatch -> "If-None-Match" + SIfRange -> "If-Range" + SIfUnmodifiedSince -> "If-Unmodified-Since" + SLastModified -> "Last-Modified" + SLink -> "Link" + SLocation -> "Location" + SMaxForwards -> "Max-Forwards" + SOrigin -> "Origin" + SPragma -> "Pragma" + SProxyAuthenticate -> "Proxy-Authenticate" + SProxyAuthorization -> "Proxy-Authorization" + SPublicKeyPins -> "Public-Key-Pins" + SRange -> "Range" + SReferer -> "Referer" + SRetryAfter -> "Retry-After" + SSetCookie -> "Set-Cookie" + SStrictTransportSecurity -> "Strict-Transport-Security" + STE -> "TE" + STrailer -> "Trailer" + STransferEncoding -> "Transfer-Encoding" + SUpgrade -> "Upgrade" + SUserAgent -> "User-Agent" + SVary -> "Vary" + SVia -> "Via" + SWWWAuthenticate -> "WWW-Authenticate" + SWarning -> "Warning" + SXCsrfToken -> "X-Csrf-Token" + SXForwardedFor -> "X-Forwarded-For" + SXForwardedHost -> "X-Forwarded-Host" + SXForwardedProto -> "X-Forwarded-Proto" nameHeader :: CI.CI Text -> HeaderType Text nameHeader n = diff --git a/src/Serv/Internal/Header/Serialization.hs b/src/Serv/Internal/Header/Serialization.hs index 7df60a0..2c2fdff 100644 --- a/src/Serv/Internal/Header/Serialization.hs +++ b/src/Serv/Internal/Header/Serialization.hs @@ -84,7 +84,7 @@ type HeaderEncodes rs = AllC (UncurrySym1 (TyCon2 HeaderEncode)) rs -- | Encode a header type and a corresponding value into a full header pair. headerPair :: HeaderEncode h v => Sing h -> v -> Maybe HTTP.Header -headerPair s v = (headerName (headerType s), ) <$> headerEncodeRaw s v +headerPair s v = (headerName s, ) <$> headerEncodeRaw s v firstName :: SingI name => Rec (name ::: ty ': rs) -> Sing name firstName _ = sing diff --git a/src/Serv/Internal/Server.hs b/src/Serv/Internal/Server.hs index 01a1363..a352484 100644 --- a/src/Serv/Internal/Server.hs +++ b/src/Serv/Internal/Server.hs @@ -208,7 +208,7 @@ handleResponse case (sBody, resp) of (SEmpty, EmptyResponse secretHeaders headers) -> - respondNoBody (StatusCode.httpStatus (fromSing sStatus)) secretHeaders headers + respondNoBody (StatusCode.httpStatus sStatus) secretHeaders headers (SHasBody sCtypes _sTy, ContentResponse secretHeaders headers a) | not includeBody -> do respondNoBody HTTP.ok200 secretHeaders headers @@ -244,7 +244,7 @@ handleResponse return $ WaiResponse $ Wai.responseLBS - (StatusCode.httpStatus (fromSing sStatus)) + (StatusCode.httpStatus sStatus) ( newHeaders ++ secretHeaders ++ HeaderS.encodeHeaders headers diff --git a/src/Serv/Internal/StatusCode.hs b/src/Serv/Internal/StatusCode.hs index 3c4976e..cfc47ca 100644 --- a/src/Serv/Internal/StatusCode.hs +++ b/src/Serv/Internal/StatusCode.hs @@ -17,6 +17,7 @@ module Serv.Internal.StatusCode where import Data.Singletons.TH +import Data.Singletons.TypeLits import qualified Network.HTTP.Types.Status as S singletons @@ -161,68 +162,68 @@ type LoopDetected = 'LoopDetected type NotExtended = 'NotExtended type NetworkAuthenticationRequired = 'NetworkAuthenticationRequired -httpStatus :: StatusCode Integer -> S.Status +httpStatus :: forall (c :: StatusCode Nat) . Sing c -> S.Status httpStatus c = case c of - CustomStatus int -> S.mkStatus (fromInteger int) "" - - Continue -> S.status100 - SwitchingProtocols -> S.status101 - - Ok -> S.status200 - Created -> S.status201 - Accepted -> S.status202 - NonAuthoritiveInformation -> S.status203 - NoContent -> S.status204 - ResetContent -> S.status205 - PartialContent -> S.status206 - IMUsed -> S.mkStatus 226 "IM Used" - - MultipleChoices -> S.status300 - MovedPermanently -> S.status301 - Found -> S.status302 - SeeOther -> S.status303 - NotModified -> S.status304 - TemporaryRedirect -> S.status307 - PermanentRedirect -> S.status308 - - BadRequest -> S.status400 - Unauthorized -> S.status401 - PaymentRequired -> S.status402 - Forbidden -> S.status403 - NotFound -> S.status404 - MethodNotAllowed -> S.status405 - NotAcceptable -> S.status406 - ProxyAuthenticationRequired -> S.status407 - RequestTimeout -> S.status408 - Conflict -> S.status409 - Gone -> S.status410 - LengthRequired -> S.status411 - PreconditionFailed -> S.status412 - PayloadTooLarge -> S.status413 - RequestURITooLong -> S.status414 - UnsupportedMediaType -> S.status415 - RequestedRangeNotSatisfiable -> S.status416 - ExpectationFailed -> S.status417 - MisdirectedRequest -> S.mkStatus 421 "Misdirected Request" - UnprocessableEntity -> S.mkStatus 422 "Unprocessable Entity" - Locked -> S.mkStatus 423 "Locked" - FailedDependency -> S.mkStatus 424 "Failed Dependency" - UpgradeRequired -> S.mkStatus 426 "Upgrade Required" - PreconditionRequired -> S.status428 - TooManyRequests -> S.status429 - RequestHeaderFieldsTooLarge -> S.status431 - UnavailableForLegalReasons -> S.mkStatus 451 "Unavailable for Legal Reasons" - - InternalServerError -> S.status500 - NotImplemented -> S.status501 - BadGateway -> S.status502 - ServiceUnavailable -> S.status503 - GatewayTimeout -> S.status504 - HTTPVersionNotSupported -> S.status505 - VariantAlsoNegotiates -> S.mkStatus 506 "Variant Also Negotiates" - InsufficientStorage -> S.mkStatus 507 "Insufficient Storage" - LoopDetected -> S.mkStatus 508 "Loop Detected" - NotExtended -> S.mkStatus 510 "Not Extended" - NetworkAuthenticationRequired -> S.status511 + SCustomStatus s -> S.mkStatus (fromInteger (withKnownNat s (natVal s))) "" + + SContinue -> S.status100 + SSwitchingProtocols -> S.status101 + + SOk -> S.status200 + SCreated -> S.status201 + SAccepted -> S.status202 + SNonAuthoritiveInformation -> S.status203 + SNoContent -> S.status204 + SResetContent -> S.status205 + SPartialContent -> S.status206 + SIMUsed -> S.mkStatus 226 "IM Used" + + SMultipleChoices -> S.status300 + SMovedPermanently -> S.status301 + SFound -> S.status302 + SSeeOther -> S.status303 + SNotModified -> S.status304 + STemporaryRedirect -> S.status307 + SPermanentRedirect -> S.status308 + + SBadRequest -> S.status400 + SUnauthorized -> S.status401 + SPaymentRequired -> S.status402 + SForbidden -> S.status403 + SNotFound -> S.status404 + SMethodNotAllowed -> S.status405 + SNotAcceptable -> S.status406 + SProxyAuthenticationRequired -> S.status407 + SRequestTimeout -> S.status408 + SConflict -> S.status409 + SGone -> S.status410 + SLengthRequired -> S.status411 + SPreconditionFailed -> S.status412 + SPayloadTooLarge -> S.status413 + SRequestURITooLong -> S.status414 + SUnsupportedMediaType -> S.status415 + SRequestedRangeNotSatisfiable -> S.status416 + SExpectationFailed -> S.status417 + SMisdirectedRequest -> S.mkStatus 421 "Misdirected Request" + SUnprocessableEntity -> S.mkStatus 422 "Unprocessable Entity" + SLocked -> S.mkStatus 423 "Locked" + SFailedDependency -> S.mkStatus 424 "Failed Dependency" + SUpgradeRequired -> S.mkStatus 426 "Upgrade Required" + SPreconditionRequired -> S.status428 + STooManyRequests -> S.status429 + SRequestHeaderFieldsTooLarge -> S.status431 + SUnavailableForLegalReasons -> S.mkStatus 451 "Unavailable for Legal Reasons" + + SInternalServerError -> S.status500 + SNotImplemented -> S.status501 + SBadGateway -> S.status502 + SServiceUnavailable -> S.status503 + SGatewayTimeout -> S.status504 + SHTTPVersionNotSupported -> S.status505 + SVariantAlsoNegotiates -> S.mkStatus 506 "Variant Also Negotiates" + SInsufficientStorage -> S.mkStatus 507 "Insufficient Storage" + SLoopDetected -> S.mkStatus 508 "Loop Detected" + SNotExtended -> S.mkStatus 510 "Not Extended" + SNetworkAuthenticationRequired -> S.status511