Eliminate use of unrefined types to simplify API appearance

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 =

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

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

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