diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Joseph Abrahamson (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/http-kinder.cabal b/http-kinder.cabal new file mode 100644 --- /dev/null +++ b/http-kinder.cabal @@ -0,0 +1,73 @@ +name: http-kinder +version: 0.2.0.0 +synopsis: Generic kinds and types for working with HTTP +description: + Types and kinds for describing HTTP requests and responsts. + . + See the README for more details. +homepage: http://github.com/tel/serv#readme +license: BSD3 +license-file: LICENSE +author: Joseph Abrahamson +maintainer: me@jspha.com +copyright: 2015 Joseph Abrahamson +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + + Network.HTTP.Kinder + Network.HTTP.Kinder.Common + Network.HTTP.Kinder.Header + Network.HTTP.Kinder.Header.Definitions + Network.HTTP.Kinder.Header.Serialization + Network.HTTP.Kinder.MediaType + Network.HTTP.Kinder.Query + Network.HTTP.Kinder.Status + Network.HTTP.Kinder.URI + Network.HTTP.Kinder.Verb + + build-depends: base >= 4.7 && < 5 + + , aeson + , bytestring + , case-insensitive + , containers + , http-media + , http-types + , singletons + , text + , time + + default-language: Haskell2010 + +test-suite http-kinder-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + + Test.Network.HTTP.Kinder.URI + + build-depends: base + , http-kinder + + , HUnit + , QuickCheck + , tasty + , tasty-ant-xml + , tasty-hunit + , tasty-quickcheck + , text + , wai + , wai-extra + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/tel/serv diff --git a/src/Network/HTTP/Kinder.hs b/src/Network/HTTP/Kinder.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder.hs @@ -0,0 +1,20 @@ +-- | Module which re-exports most types from submodules in this package. +module Network.HTTP.Kinder ( + + module Network.HTTP.Kinder.Common + , module Network.HTTP.Kinder.Header + , module Network.HTTP.Kinder.MediaType + , module Network.HTTP.Kinder.Query + , module Network.HTTP.Kinder.Status + , module Network.HTTP.Kinder.URI + , module Network.HTTP.Kinder.Verb + +) where + +import Network.HTTP.Kinder.Common +import Network.HTTP.Kinder.Header +import Network.HTTP.Kinder.MediaType +import Network.HTTP.Kinder.Query +import Network.HTTP.Kinder.Status +import Network.HTTP.Kinder.URI +import Network.HTTP.Kinder.Verb diff --git a/src/Network/HTTP/Kinder/Common.hs b/src/Network/HTTP/Kinder/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/Common.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Common types useful for the "kinder" HTTP system. +module Network.HTTP.Kinder.Common where + +import Data.String + +-- | 'Raw' is an identity-like newtype wrapper which is used as an +-- indicator that a serialization should return the "raw" underlying +-- values. For instance, an instance of 'HeaderDecode' for @'Raw' 'Text'@ +-- would return exactly the text value of the header whereas one for 'Text' +-- would only parse if the values were quoted. +newtype Raw a = Raw { getRaw :: a } + deriving (Eq, Ord, Read, Show, Monoid, IsString) diff --git a/src/Network/HTTP/Kinder/Header.hs b/src/Network/HTTP/Kinder/Header.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/Header.hs @@ -0,0 +1,32 @@ + +-- | Re-exports generally useful values from +-- "Network.HTTP.Kinder.Header.Definitions" and +-- "Network.HTTP.Kinder.Header.Serialization". +-- +-- HTTP headers handled at the type level. This module provides types and +-- kinds (with @DataKinds@ enabled) to represent most headers as types and +-- serialize or desrialize header values accordingly. +-- +-- For instance, these methods describe that we can interpret values at the +-- 'Network.HTTP.Kinder.Header.Definitions.ContentType' header as a set of +-- media types or at +-- 'Network.HTTP.Kinder.Header.Definitions.AccessControlMaxAge' as +-- a 'Data.Time.NominalDiffTime'. See the instances for +-- 'Network.HTTP.Kinder.Header.Serialization.HeaderEncode' and +-- 'Network.HTTP.Kinder.Header.Serialization.HeaderDecode' for more detail. +module Network.HTTP.Kinder.Header ( + + module Network.HTTP.Kinder.Header.Definitions + , module Network.HTTP.Kinder.Header.Serialization + +) where + +import Network.HTTP.Kinder.Header.Definitions +import Network.HTTP.Kinder.Header.Serialization (AllHeaderDecodes, + AllHeaderEncodes, + HeaderDecode (..), + HeaderEncode (..), + headerDecodeBS, + headerEncodeBS, + headerEncodePair) + diff --git a/src/Network/HTTP/Kinder/Header/Definitions.hs b/src/Network/HTTP/Kinder/Header/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/Header/Definitions.hs @@ -0,0 +1,974 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Defines the types and kinds for working with type and value level headers. +-- +-- In particular, this module exports a datatype, 'HeaderName' which is +-- meant to be used with @DataKinds@ providing one type, e.g. ''Accept' for +-- every common header name (and an override one 'CustomHeader'). It also +-- exports 'Sing' values for each 'HeaderName'-kinded type each merely +-- being the name of that type prepended with @S@. +-- +-- Finally, it exports a set of type synonms for each 'HeaderName'-kinded +-- type so that they can be referenced without the quote prefix @'@. +module Network.HTTP.Kinder.Header.Definitions ( + + -- * Functions and types for working with 'HeaderName' 'Sing's + SomeHeaderName (SomeHeaderName) + , headerName + , parseHeaderName + + -- * The 'HeaderName' type/kind + , HeaderName (..) + , Sing ( + SCustomHeader + , SAccept + , SAcceptCharset + , SAcceptEncoding + , SAcceptLanguage + , SAcceptPatch + , SAcceptRanges + , SAccessControlAllowCredentials + , SAccessControlAllowHeaders + , SAccessControlAllowMethods + , SAccessControlAllowOrigin + , SAccessControlExposeHeaders + , SAccessControlMaxAge + , SAccessControlRequestHeaders + , SAccessControlRequestMethod + , SAge + , SAllow + , SAuthorization + , SCacheControl + , SConnection + , SContentDisposition + , SContentEncoding + , SContentLanguage + , SContentLength + , SContentLocation + , SContentRange + , SContentSecurityPolicy + , SContentType + , SCookie + , SDate + , SETag + , SExpect + , SExpires + , SFrom + , SHost + , SIfMatch + , SIfModifiedSince + , SIfNoneMatch + , SIfRange + , SIfUnmodifiedSince + , SLastModified + , SLink + , SLocation + , SMaxForwards + , SOrigin + , SPragma + , SProxyAuthenticate + , SProxyAuthorization + , SPublicKeyPins + , SRange + , SReferer + , SRetryAfter + , SSetCookie + , SStrictTransportSecurity + , STE + , STrailer + , STransferEncoding + , SUpgrade + , SUserAgent + , SVary + , SVia + , SWWWAuthenticate + , SWarning + , SXCsrfToken + , SXForwardedFor + , SXForwardedHost + , SXForwardedProto + ) + + -- * Type synonyms for more convenient use of 'HeaderName's + + , CustomHeader + , Accept + , AcceptCharset + , AcceptEncoding + , AcceptLanguage + , AcceptPatch + , AcceptRanges + , AccessControlAllowCredentials + , AccessControlAllowHeaders + , AccessControlAllowMethods + , AccessControlAllowOrigin + , AccessControlExposeHeaders + , AccessControlMaxAge + , AccessControlRequestHeaders + , AccessControlRequestMethod + , Age + , Allow + , Authorization + , CacheControl + , Connection + , ContentDisposition + , ContentEncoding + , ContentLanguage + , ContentLength + , ContentLocation + , ContentRange + , ContentSecurityPolicy + , ContentType + , Cookie + , Date + , ETag + , Expect + , Expires + , From + , Host + , IfMatch + , IfModifiedSince + , IfNoneMatch + , IfRange + , IfUnmodifiedSince + , LastModified + , Link + , Location + , MaxForwards + , Origin + , Pragma + , ProxyAuthenticate + , ProxyAuthorization + , PublicKeyPins + , Range + , Referer + , RetryAfter + , SetCookie + , StrictTransportSecurity + , TE + , Trailer + , TransferEncoding + , Upgrade + , UserAgent + , Vary + , Via + , WWWAuthenticate + , Warning + , XCsrfToken + , XForwardedFor + , XForwardedHost + , XForwardedProto + +) where + +import qualified Data.CaseInsensitive as CI +import Data.Singletons +import Data.Singletons.TypeLits +import Data.String +import Data.Text (Text) +import qualified Data.Text as T + +-- | It's difficult to get ahold of values of 'HeaderName' directly since +-- they may contain 'Symbol' values which do not exist. Instead, we can get +-- almost the same effect through an existential which holds a singleton at +-- the 'HeaderName' kind +-- +-- Note that while the Haddocks show this as taking any 'Sing' type it is +-- actually constrained only to have 'Sing's of kind 'HeaderName'. +data SomeHeaderName where + SomeHeaderName :: forall (h :: HeaderName) . Sing h -> SomeHeaderName + +instance Show SomeHeaderName where + show (SomeHeaderName h) = "SomeHeaderName " ++ headerName h + +-- | Equality is slightly strange for 'SomeHeaderName'---we equate, e.g., +-- @'Accept'@ and @'CustomHeader' "accept"@. +instance Eq SomeHeaderName where + a == b = proj a == proj b where + proj :: SomeHeaderName -> CI.CI String + proj (SomeHeaderName h) = headerName h + +instance Ord SomeHeaderName where + a `compare` b = proj a `compare` proj b where + proj :: SomeHeaderName -> CI.CI String + proj (SomeHeaderName h) = headerName h + +instance IsString SomeHeaderName where + fromString = parseHeaderName . fromString + +-- | Extract a string-like representation of a 'HeaderName' 'Sing'. +headerName :: forall s (h :: HeaderName) . IsString s => Sing h -> s +headerName h = + case h of + SCustomHeader sym -> withKnownSymbol sym (fromString $ symbolVal sym) + 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" + +-- | Construct a 'HeaderType' 'Sing' from a string representation. This +-- will try to use a standard header type if possible or will default to +-- 'CustomHeader'. +parseHeaderName :: CI.CI Text -> SomeHeaderName +parseHeaderName n = + case n of + "Accept" -> SomeHeaderName SAccept + "Accept-Charset" -> SomeHeaderName SAcceptCharset + "Accept-Encoding" -> SomeHeaderName SAcceptEncoding + "Accept-Language" -> SomeHeaderName SAcceptLanguage + "Accept-Patch" -> SomeHeaderName SAcceptPatch + "Accept-Ranges" -> SomeHeaderName SAcceptRanges + "Access-Control-Allow-Credentials" -> SomeHeaderName SAccessControlAllowCredentials + "Access-Control-Allow-Headers" -> SomeHeaderName SAccessControlAllowHeaders + "Access-Control-Allow-Methods" -> SomeHeaderName SAccessControlAllowMethods + "Access-Control-Allow-Origin" -> SomeHeaderName SAccessControlAllowOrigin + "Access-Control-Expose-Headers" -> SomeHeaderName SAccessControlExposeHeaders + "Access-Control-Max-Age" -> SomeHeaderName SAccessControlMaxAge + "Access-Control-Request-Headers" -> SomeHeaderName SAccessControlRequestHeaders + "Access-Control-Request-Method" -> SomeHeaderName SAccessControlRequestMethod + "Age" -> SomeHeaderName SAge + "Allow" -> SomeHeaderName SAllow + "Authorization" -> SomeHeaderName SAuthorization + "Cache-Control" -> SomeHeaderName SCacheControl + "Connection" -> SomeHeaderName SConnection + "Content-Disposition" -> SomeHeaderName SContentDisposition + "Content-Encoding" -> SomeHeaderName SContentEncoding + "Content-Language" -> SomeHeaderName SContentLanguage + "Content-Length" -> SomeHeaderName SContentLength + "Content-Location" -> SomeHeaderName SContentLocation + "Content-Range" -> SomeHeaderName SContentRange + "Content-Security-Policy" -> SomeHeaderName SContentSecurityPolicy + "Content-Type" -> SomeHeaderName SContentType + "Cookie" -> SomeHeaderName SCookie + "Date" -> SomeHeaderName SDate + "ETag" -> SomeHeaderName SETag + "Expect" -> SomeHeaderName SExpect + "Expires" -> SomeHeaderName SExpires + "From" -> SomeHeaderName SFrom + "Host" -> SomeHeaderName SHost + "If-Match" -> SomeHeaderName SIfMatch + "If-Modified-Since" -> SomeHeaderName SIfModifiedSince + "If-None-Match" -> SomeHeaderName SIfNoneMatch + "If-Range" -> SomeHeaderName SIfRange + "If-Unmodified-Since" -> SomeHeaderName SIfUnmodifiedSince + "Last-Modified" -> SomeHeaderName SLastModified + "Link" -> SomeHeaderName SLink + "Location" -> SomeHeaderName SLocation + "Max-Forwards" -> SomeHeaderName SMaxForwards + "Origin" -> SomeHeaderName SOrigin + "Pragma" -> SomeHeaderName SPragma + "Proxy-Authenticate" -> SomeHeaderName SProxyAuthenticate + "Proxy-Authorization" -> SomeHeaderName SProxyAuthorization + "Public-Key-Pins" -> SomeHeaderName SPublicKeyPins + "Range" -> SomeHeaderName SRange + "Referer" -> SomeHeaderName SReferer + "Retry-After" -> SomeHeaderName SRetryAfter + "Set-Cookie" -> SomeHeaderName SSetCookie + "Strict-Transport-Security" -> SomeHeaderName SStrictTransportSecurity + "TE" -> SomeHeaderName STE + "Trailer" -> SomeHeaderName STrailer + "Transfer-Encoding" -> SomeHeaderName STransferEncoding + "Upgrade" -> SomeHeaderName SUpgrade + "User-Agent" -> SomeHeaderName SUserAgent + "Vary" -> SomeHeaderName SVary + "Via" -> SomeHeaderName SVia + "WWW-Authenticate" -> SomeHeaderName SWWWAuthenticate + "Warning" -> SomeHeaderName SWarning + "X-Csrf-Token" -> SomeHeaderName SXCsrfToken + "X-Forwarded-For" -> SomeHeaderName SXForwardedFor + "X-Forwarded-Host" -> SomeHeaderName SXForwardedHost + "X-Forwarded-Proto" -> SomeHeaderName SXForwardedProto + other -> + case toSing (T.unpack (CI.original other)) :: SomeSing ('KProxy :: KProxy Symbol) of + SomeSing s -> SomeHeaderName (SCustomHeader s) + +-- | A data type representing names describing headers in an HTTP request +-- or response. Much more importantly, with @DataKinds@ enabled this +-- becomes a kind describing types, one for each such header name. +-- +-- It's worth noting that values of this type can be had, but one branch, +-- 'CustomHeader' will not work since it requires 'Symbol' values which +-- cannot be had. For this reason prefer using values of 'SomeHeaderName' +-- instead of values of 'HeaderName' directly. +data HeaderName + + ---- WILDCARD HEADER NAMES + + = CustomHeader Symbol + -- ^ Inject an arbitatry symbol in as a 'HeaderName'. This can be used to + -- implement any sort of custom header + + + + ---- COMMON HEADER NAMES + + + | CacheControl + -- ^ Used to specify directives that must be obeyed by all caching mechanisms + -- along the request-response chain. Tells all caching mechanisms from server + -- to client whether they may cache this object. It is measured in seconds + -- + -- Cache-Control: no-cache + + | Connection + -- ^ Control options for the current connection and list of hop-by-hop + -- request fields + -- + -- Connection: keep-alive + -- Connection: Upgrade + + | ContentLength + -- ^ The length of the request body in octets (8-bit bytes) + -- + -- Content-Length: 348 + + | ContentType + -- ^ The MIME type of the body of the request (used with POST and PUT requests) + -- + -- Content-Type: application/x-www-form-urlencoded + + | Date + -- ^ The date and time that the message was sent (in "HTTP-date" format as + -- defined by RFC 7231 Date/Time Formats) + -- + -- Date: Tue, 15 Nov 1994 08:12:31 GMT + + | Pragma + -- ^ Implementation-specific fields that may have various effects anywhere + -- along the request-response chain. + -- + -- Pragma: no-cache + + | Upgrade + -- ^ Ask the server to upgrade to another protocol. + -- + -- Upgrade: HTTP/2.0, SHTTP/1.3, IRC/6.9, RTA/x11 + + | Via + -- ^ Informs the server of proxies through which the request was sent. + -- + -- Via: 1.0 fred, 1.1 example.com (Apache/1.1) + + | Warning + -- ^ A general warning about possible problems with the entity body. + -- + -- Warning: 199 Miscellaneous warning + + + + ---- REQUEST-SPECIFIC HEADER NAMES + + + | Accept + -- ^ Content-Types that are acceptable for the response. + -- + -- Accept: text/plain + + | AcceptCharset + -- ^ Character sets that are acceptable + -- + -- Accept-Charset: utf-8 + + | AcceptEncoding + -- ^ List of acceptable encodings. + -- + -- Accept-Encoding: gzip, deflate + + | AcceptLanguage + -- ^ List of acceptable human languages for response. + -- + -- Accept-Language: en-US + + | AccessControlRequestMethod + -- ^ Used when issuing a preflight request to let the server + -- know what HTTP method will be used when the actual request is made. + -- + -- Access-Control-Request-Method: POST + + | AccessControlRequestHeaders + -- ^ Used when issuing a preflight request to let the server know + -- what HTTP headers will be used when the actual request is made. + -- + -- Access-Control-Request-Headers: X-PINGOTHER + + | Authorization + -- ^ Authentication credentials for HTTP authentication + -- + -- Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ== + + | Cookie + -- ^ An HTTP cookie previously sent by the server with Set-Cookie (below) + -- + -- Cookie: $Version=1; Skin=new; + + | Expect + -- ^ Indicates that particular server behaviors are required by the client + -- + -- Expect: 100-continue + + | From + -- ^ The email address of the user making the request + -- + -- From: user@example.com + + | Host + -- ^ The domain name of the server (for virtual hosting), and the TCP port + -- number on which the server is listening. The port number may be omitted + -- if the port is the standard port for the service requested. + -- + -- Host: en.wikipedia.org:80 + -- Host: en.wikipedia.org + + | IfMatch + -- ^ Only perform the action if the client supplied entity matches the same + -- entity on the server. This is mainly for methods like PUT to only update + -- a resource if it has not been modified since the user last updated it. + -- + -- If-Match: "737060cd8c284d8af7ad3082f209582d" + + | IfModifiedSince + -- ^ Allows a 304 Not Modified to be returned if content is unchanged + -- + -- If-Modified-Since: Sat, 29 Oct 1994 19:43:31 GMT + + | IfNoneMatch + -- ^ Allows a 304 Not Modified to be returned if content is unchanged, + -- see HTTP ETag + -- + -- If-None-Match: "737060cd8c284d8af7ad3082f209582d" + + | IfRange + -- ^ If the entity is unchanged, send me the part(s) that I am missing; + -- otherwise, send me the entire new entity + -- + -- If-Range: "737060cd8c284d8af7ad3082f209582d" + + | IfUnmodifiedSince + -- ^ Only send the response if the entity has not been modified since a + -- specific time. + -- + -- If-Unmodified-Since: Sat, 29 Oct 1994 19:43:31 GMT + + | MaxForwards + -- ^ Limit the number of times the message can be forwarded through proxies + -- or gateways. + -- + -- Max-Forwards: 10 + + | Origin + -- ^ Initiates a request for cross-origin resource sharing (asks server for + -- an 'Access-Control-Allow-Origin' response field). + -- + -- Origin: http://www.example-social-network.com + + | ProxyAuthorization + -- ^ Authorization credentials for connecting to a proxy. + -- + -- Proxy-Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ== + + | Range + -- ^ Request only part of an entity. Bytes are numbered from 0. + -- + -- Range: bytes=500-999 + + | Referer + -- ^ This is the address of the previous web page from which a link to the + -- currently requested page was followed. (The word “referrer” has been + -- misspelled in the RFC as well as in most implementations to the point + -- that it has become standard usage and is considered correct terminology) + -- + -- Referer: http://en.wikipedia.org/wiki/Main_Page + + | TE + -- ^ The transfer encodings the user agent is willing to accept: the same + -- values as for the response header field Transfer-Encoding can be used, + -- plus the "trailers" value (related to the "chunked" transfer method) to + -- notify the server it expects to receive additional fields in the trailer + -- after the last, zero-sized, chunk. + -- + -- TE: trailers, deflate + + | UserAgent + -- ^ The user agent string of the user agent + -- + -- User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:12.0) Gecko/20100101 Firefox/21.0 + + | XForwardedFor + -- ^ A de facto standard for identifying the originating IP address of a + -- client connecting to a web server through an HTTP proxy or load balancer + -- + -- X-Forwarded-For: client1, proxy1, proxy2 + -- X-Forwarded-For: 129.78.138.66, 129.78.64.103 + + | XForwardedHost + -- ^ A de facto standard for identifying the original host requested by the client in + -- the Host HTTP request header, since the host name and/or port of the reverse + -- proxy (load balancer) may differ from the origin server handling the request. + -- + -- X-Forwarded-Host: en.wikipedia.org:80 + -- X-Forwarded-Host: en.wikipedia.org + + | XForwardedProto + -- ^ A de facto standard for identifying the originating protocol of an HTTP request, + -- since a reverse proxy (or a load balancer) may communicate with a web server using + -- HTTP even if the request to the reverse proxy is HTTPS. + + | XCsrfToken + -- ^ Used to prevent cross-site request forgery. + -- + -- X-Csrf-Token: i8XNjC4b8KVok4uw5RftR38Wgp2BFwql + + + + + ---- RESPONSE-SPECIFIC HEADER NAMES + + + | AccessControlAllowOrigin + -- ^ When responding to a CORS request this lists either + -- an origin or @*@ describing the server's CORS policy for + -- the requested resource + -- + -- Access-Control-Allow-Origin: * + -- Access-Control-Allow-Origin: http://foo.example + -- Access-Control-Allow-Origin: https://foo.example + + | AccessControlExposeHeaders + -- ^ This header lets a server whitelist headers that browsers are allowed to access. + -- + -- Access-Control-Expose-Headers: X-My-Custom-Header, X-Another-Custom-Header + + | AccessControlMaxAge + -- ^ This header indicates how long the results of a preflight request can be cached. + -- + -- Access-Control-Max-Age: + + | AccessControlAllowCredentials + -- ^ Indicates whether or not the response to the request can be exposed when the + -- credentials flag is true. When used as part of a response to a preflight request, + -- this indicates whether or not the actual request can be made using credentials. Note + -- that simple GET requests are not preflighted, and so if a request is made for a + -- resource with credentials, if this header is not returned with the resource, the + -- response is ignored by the browser and not returned to web content. + -- + -- Access-Control-Allow-Credentials: true | false + + | AccessControlAllowMethods + -- ^ Specifies the method or methods allowed when accessing the resource. This is + -- used in response to a preflight request. + -- + -- Access-Control-Allow-Methods: [, ]* + + | AccessControlAllowHeaders + -- ^ Used in response to a preflight request to indicate which HTTP headers can + -- be used when making the actual request. + + | AcceptPatch + -- ^ Specifies which patch document formats this server supports + -- + -- Accept-Patch: text/example;charset=utf-8 + + | AcceptRanges + -- ^ What partial content range types this server supports via byte serving + -- + -- Accept-Ranges: bytes + + | Age + -- ^ The age the object has been in a proxy cache in seconds + -- + -- Age: 12 + + | Allow + -- ^ Valid actions for a specified resource. To be used for a 405 Method not allowed + -- + -- Allow: GET, HEAD + + | ContentDisposition + -- ^ An opportunity to raise a "File Download" dialogue box for a known MIME type + -- with binary format or suggest a filename for dynamic content. Quotes are + -- necessary with special characters. + -- + -- Content-Disposition: attachment; filename="fname.ext" + + | ContentEncoding + -- ^ The type of encoding used on the data. + -- + -- Content-Encoding: gzip + + | ContentLanguage + -- ^ The natural language or languages of the intended audience for the enclosed content + -- + -- Content-Language: da + + | ContentLocation + -- ^ An alternate location for the returned data + -- + -- Content-Location: /index.htm + + | ContentRange + -- ^ Where in a full body message this partial message belongs + -- + -- Content-Range: bytes 21010-47021/47022 + + | ContentSecurityPolicy + -- ^ Content Security Policy definition. + -- + -- Content-Security-Policy: default-src 'self' + + | ETag + -- ^ An identifier for a specific version of a resource, often a message digest + -- + -- ETag: "737060cd8c284d8af7ad3082f209582d" + + | Expires + -- ^ Gives the date/time after which the response is considered stale (in + -- "HTTP-date" format as defined by RFC 7231) + -- + -- Expires: Thu, 01 Dec 1994 16:00:00 GMT + + | LastModified + -- ^ The last modified date for the requested object (in "HTTP-date" format as + -- defined by RFC 7231) + -- + -- Last-Modified: Tue, 15 Nov 1994 12:45:26 GMT + + | Link + -- ^ Used to express a typed relationship with another resource, where the + -- relation type is defined by RFC 5988 + -- + -- Link: ; rel="alternate" + + | Location + -- ^ Used in redirection, or when a new resource has been created. + -- + -- Location: http://www.w3.org/pub/WWW/People.html + + | ProxyAuthenticate + -- ^ Request authentication to access the proxy. + -- + -- Proxy-Authenticate: Basic + + | PublicKeyPins + -- ^ HTTP Public Key Pinning, announces hash of website's authentic TLS certificate + -- + -- Public-Key-Pins: max-age=2592000; pin-sha256="E9CZ9INDbd+2eRQozYqqbQ2yXLVKB9+xcprMF+44U1g="; + + | RetryAfter + -- ^ If an entity is temporarily unavailable, this instructs the client to + -- try again later. Value could be a specified period of time (in seconds) or a HTTP-date. + -- + -- Retry-After: 120 + -- Retry-After: Fri, 07 Nov 2014 23:59:59 GMT + + | SetCookie + -- ^ An HTTP cookie + -- + -- Set-Cookie: UserID=JohnDoe; Max-Age=3600; Version=1 + + | StrictTransportSecurity + -- ^ A HSTS Policy informing the HTTP client how long to cache the HTTPS only + -- policy and whether this applies to subdomains. + -- + -- Strict-Transport-Security: max-age=16070400; includeSubDomains + + | Trailer + -- ^ The Trailer general field value indicates that the given set of header fields + -- is present in the trailer of a message encoded with chunked transfer coding. + -- + -- Trailer: Max-Forwards + + | TransferEncoding + -- ^ The form of encoding used to safely transfer the entity to the user. Currently defined + -- methods are: chunked, compress, deflate, gzip, identity. + -- + -- Transfer-Encoding: chunked + + | Vary + -- ^ Tells downstream proxies how to match future request headers to decide whether + -- the cached response can be used rather than requesting a fresh one from the origin server. + -- + -- Vary: * + -- Vary: Accept-Language + + | WWWAuthenticate + -- ^ Indicates the authentication scheme that should be used to access the requested entity. + -- + -- WWW-Authenticate: Basic + +type CustomHeader s = 'CustomHeader s +type Accept = 'Accept +type AcceptCharset = 'AcceptCharset +type AcceptEncoding = 'AcceptEncoding +type AcceptLanguage = 'AcceptLanguage +type AcceptPatch = 'AcceptPatch +type AcceptRanges = 'AcceptRanges +type AccessControlAllowCredentials = 'AccessControlAllowCredentials +type AccessControlAllowHeaders = 'AccessControlAllowHeaders +type AccessControlAllowMethods = 'AccessControlAllowMethods +type AccessControlAllowOrigin = 'AccessControlAllowOrigin +type AccessControlExposeHeaders = 'AccessControlExposeHeaders +type AccessControlMaxAge = 'AccessControlMaxAge +type AccessControlRequestHeaders = 'AccessControlRequestHeaders +type AccessControlRequestMethod = 'AccessControlRequestMethod +type Age = 'Age +type Allow = 'Allow +type Authorization = 'Authorization +type CacheControl = 'CacheControl +type Connection = 'Connection +type ContentDisposition = 'ContentDisposition +type ContentEncoding = 'ContentEncoding +type ContentLanguage = 'ContentLanguage +type ContentLength = 'ContentLength +type ContentLocation = 'ContentLocation +type ContentRange = 'ContentRange +type ContentSecurityPolicy = 'ContentSecurityPolicy +type ContentType = 'ContentType +type Cookie = 'Cookie +type Date = 'Date +type ETag = 'ETag +type Expect = 'Expect +type Expires = 'Expires +type From = 'From +type Host = 'Host +type IfMatch = 'IfMatch +type IfModifiedSince = 'IfModifiedSince +type IfNoneMatch = 'IfNoneMatch +type IfRange = 'IfRange +type IfUnmodifiedSince = 'IfUnmodifiedSince +type LastModified = 'LastModified +type Link = 'Link +type Location = 'Location +type MaxForwards = 'MaxForwards +type Origin = 'Origin +type Pragma = 'Pragma +type ProxyAuthenticate = 'ProxyAuthenticate +type ProxyAuthorization = 'ProxyAuthorization +type PublicKeyPins = 'PublicKeyPins +type Range = 'Range +type Referer = 'Referer +type RetryAfter = 'RetryAfter +type SetCookie = 'SetCookie +type StrictTransportSecurity = 'StrictTransportSecurity +type TE = 'TE +type Trailer = 'Trailer +type TransferEncoding = 'TransferEncoding +type Upgrade = 'Upgrade +type UserAgent = 'UserAgent +type Vary = 'Vary +type Via = 'Via +type WWWAuthenticate = 'WWWAuthenticate +type Warning = 'Warning +type XCsrfToken = 'XCsrfToken +type XForwardedFor = 'XForwardedFor +type XForwardedHost = 'XForwardedHost +type XForwardedProto = 'XForwardedProto + +-- ---------------------------------------------------------------------------- +-- These could be generated by TH, but we're inlining them! Not only is +-- this faster but it also properly handles the fact that there is no +-- reasonable 'DemoteRep' available +-- ---------------------------------------------------------------------------- + +data instance Sing (h :: HeaderName) + = forall s . h ~ CustomHeader s => SCustomHeader (Sing s) + | h ~ Accept => SAccept + | h ~ AcceptCharset => SAcceptCharset + | h ~ AcceptEncoding => SAcceptEncoding + | h ~ AcceptLanguage => SAcceptLanguage + | h ~ AcceptPatch => SAcceptPatch + | h ~ AcceptRanges => SAcceptRanges + | h ~ AccessControlAllowCredentials => SAccessControlAllowCredentials + | h ~ AccessControlAllowHeaders => SAccessControlAllowHeaders + | h ~ AccessControlAllowMethods => SAccessControlAllowMethods + | h ~ AccessControlAllowOrigin => SAccessControlAllowOrigin + | h ~ AccessControlExposeHeaders => SAccessControlExposeHeaders + | h ~ AccessControlMaxAge => SAccessControlMaxAge + | h ~ AccessControlRequestHeaders => SAccessControlRequestHeaders + | h ~ AccessControlRequestMethod => SAccessControlRequestMethod + | h ~ Age => SAge + | h ~ Allow => SAllow + | h ~ Authorization => SAuthorization + | h ~ CacheControl => SCacheControl + | h ~ Connection => SConnection + | h ~ ContentDisposition => SContentDisposition + | h ~ ContentEncoding => SContentEncoding + | h ~ ContentLanguage => SContentLanguage + | h ~ ContentLength => SContentLength + | h ~ ContentLocation => SContentLocation + | h ~ ContentRange => SContentRange + | h ~ ContentSecurityPolicy => SContentSecurityPolicy + | h ~ ContentType => SContentType + | h ~ Cookie => SCookie + | h ~ Date => SDate + | h ~ ETag => SETag + | h ~ Expect => SExpect + | h ~ Expires => SExpires + | h ~ From => SFrom + | h ~ Host => SHost + | h ~ IfMatch => SIfMatch + | h ~ IfModifiedSince => SIfModifiedSince + | h ~ IfNoneMatch => SIfNoneMatch + | h ~ IfRange => SIfRange + | h ~ IfUnmodifiedSince => SIfUnmodifiedSince + | h ~ LastModified => SLastModified + | h ~ Link => SLink + | h ~ Location => SLocation + | h ~ MaxForwards => SMaxForwards + | h ~ Origin => SOrigin + | h ~ Pragma => SPragma + | h ~ ProxyAuthenticate => SProxyAuthenticate + | h ~ ProxyAuthorization => SProxyAuthorization + | h ~ PublicKeyPins => SPublicKeyPins + | h ~ Range => SRange + | h ~ Referer => SReferer + | h ~ RetryAfter => SRetryAfter + | h ~ SetCookie => SSetCookie + | h ~ StrictTransportSecurity => SStrictTransportSecurity + | h ~ TE => STE + | h ~ Trailer => STrailer + | h ~ TransferEncoding => STransferEncoding + | h ~ Upgrade => SUpgrade + | h ~ UserAgent => SUserAgent + | h ~ Vary => SVary + | h ~ Via => SVia + | h ~ WWWAuthenticate => SWWWAuthenticate + | h ~ Warning => SWarning + | h ~ XCsrfToken => SXCsrfToken + | h ~ XForwardedFor => SXForwardedFor + | h ~ XForwardedHost => SXForwardedHost + | h ~ XForwardedProto => SXForwardedProto + +instance SingI s => SingI ('CustomHeader s) where sing = SCustomHeader sing +instance SingI 'Accept where sing = SAccept +instance SingI 'AcceptCharset where sing = SAcceptCharset +instance SingI 'AcceptEncoding where sing = SAcceptEncoding +instance SingI 'AcceptLanguage where sing = SAcceptLanguage +instance SingI 'AcceptPatch where sing = SAcceptPatch +instance SingI 'AcceptRanges where sing = SAcceptRanges +instance SingI 'AccessControlAllowCredentials where sing = SAccessControlAllowCredentials +instance SingI 'AccessControlAllowHeaders where sing = SAccessControlAllowHeaders +instance SingI 'AccessControlAllowMethods where sing = SAccessControlAllowMethods +instance SingI 'AccessControlAllowOrigin where sing = SAccessControlAllowOrigin +instance SingI 'AccessControlExposeHeaders where sing = SAccessControlExposeHeaders +instance SingI 'AccessControlMaxAge where sing = SAccessControlMaxAge +instance SingI 'AccessControlRequestHeaders where sing = SAccessControlRequestHeaders +instance SingI 'AccessControlRequestMethod where sing = SAccessControlRequestMethod +instance SingI 'Age where sing = SAge +instance SingI 'Allow where sing = SAllow +instance SingI 'Authorization where sing = SAuthorization +instance SingI 'CacheControl where sing = SCacheControl +instance SingI 'Connection where sing = SConnection +instance SingI 'ContentDisposition where sing = SContentDisposition +instance SingI 'ContentEncoding where sing = SContentEncoding +instance SingI 'ContentLanguage where sing = SContentLanguage +instance SingI 'ContentLength where sing = SContentLength +instance SingI 'ContentLocation where sing = SContentLocation +instance SingI 'ContentRange where sing = SContentRange +instance SingI 'ContentSecurityPolicy where sing = SContentSecurityPolicy +instance SingI 'ContentType where sing = SContentType +instance SingI 'Cookie where sing = SCookie +instance SingI 'Date where sing = SDate +instance SingI 'ETag where sing = SETag +instance SingI 'Expect where sing = SExpect +instance SingI 'Expires where sing = SExpires +instance SingI 'From where sing = SFrom +instance SingI 'Host where sing = SHost +instance SingI 'IfMatch where sing = SIfMatch +instance SingI 'IfModifiedSince where sing = SIfModifiedSince +instance SingI 'IfNoneMatch where sing = SIfNoneMatch +instance SingI 'IfRange where sing = SIfRange +instance SingI 'IfUnmodifiedSince where sing = SIfUnmodifiedSince +instance SingI 'LastModified where sing = SLastModified +instance SingI 'Link where sing = SLink +instance SingI 'Location where sing = SLocation +instance SingI 'MaxForwards where sing = SMaxForwards +instance SingI 'Origin where sing = SOrigin +instance SingI 'Pragma where sing = SPragma +instance SingI 'ProxyAuthenticate where sing = SProxyAuthenticate +instance SingI 'ProxyAuthorization where sing = SProxyAuthorization +instance SingI 'PublicKeyPins where sing = SPublicKeyPins +instance SingI 'Range where sing = SRange +instance SingI 'Referer where sing = SReferer +instance SingI 'RetryAfter where sing = SRetryAfter +instance SingI 'SetCookie where sing = SSetCookie +instance SingI 'StrictTransportSecurity where sing = SStrictTransportSecurity +instance SingI 'TE where sing = STE +instance SingI 'Trailer where sing = STrailer +instance SingI 'TransferEncoding where sing = STransferEncoding +instance SingI 'Upgrade where sing = SUpgrade +instance SingI 'UserAgent where sing = SUserAgent +instance SingI 'Vary where sing = SVary +instance SingI 'Via where sing = SVia +instance SingI 'WWWAuthenticate where sing = SWWWAuthenticate +instance SingI 'Warning where sing = SWarning +instance SingI 'XCsrfToken where sing = SXCsrfToken +instance SingI 'XForwardedFor where sing = SXForwardedFor +instance SingI 'XForwardedHost where sing = SXForwardedHost +instance SingI 'XForwardedProto where sing = SXForwardedProto diff --git a/src/Network/HTTP/Kinder/Header/Serialization.hs b/src/Network/HTTP/Kinder/Header/Serialization.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/Header/Serialization.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | 'HeaderName's define semantics for 'Text' values seen in HTTP headers +-- over the wire. This module provides classes to map both to and from +-- these reprsentations. +module Network.HTTP.Kinder.Header.Serialization ( + + + -- * Classes for encoding and decoding + + HeaderEncode (..) + , HeaderDecode (..) + + -- ** Listing constraints to type-level lists + + , AllHeaderEncodes + , AllHeaderDecodes + + -- * Extra serialization utilities + + , headerEncodePair + , headerEncodeBS + , headerDecodeBS + + -- * Utilities for writing serialization instances + + , displaySetOpt + , uniqueSet + , required + , withDefault + +) where + +import qualified Data.ByteString as S +import Data.CaseInsensitive (CI) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Singletons +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time +import GHC.Exts +import Network.HTTP.Kinder.Common +import Network.HTTP.Kinder.Header.Definitions +import Network.HTTP.Kinder.Verb +import Network.HTTP.Media (MediaType, Quality) +import qualified Network.HTTP.Media as Media + +-- | Determines a 'Text' representation for some value to be encoded as +-- a value of a given 'HeaderName'. Any proxy can be passed as the first +-- argument, although 'Sing' is a nice one to choose. Encodings may choose +-- to not be represented on the wire at all as desired by returning +-- 'Nothing'. This implies default behavior. +class HeaderEncode (n :: HeaderName) a where + headerEncode :: sing n -> a -> Maybe Text + +-- | For a given concrete type @a@, a list of pairs @ts@ satisfies +-- @'AllHeaderEncode' a ts@ if each @(n, a)@ in @ts@ has @'HeaderEncode' +-- n a@. +type family AllHeaderEncodes hs :: Constraint where + AllHeaderEncodes '[] = () + AllHeaderEncodes ( '(n, a) ': hs ) = (HeaderEncode n a, AllHeaderEncodes hs) + +-- | Encode a 'HeaderName' singleton and a 'HeaderEncode'-represented value +-- as a pair of name and representation, ready to be sent over the wire. +headerEncodePair + :: forall a (n :: HeaderName) + . HeaderEncode n a => Sing n -> a -> Maybe (CI S.ByteString, S.ByteString) +headerEncodePair s a = do + bs <- headerEncodeBS s a + return (headerName s, bs) + +-- | While the semantics of HTTP headers are built off of 'Text'-like +-- values, usually we require a 'S.ByteString' for emission. This helper +-- function converts a header value directly to a 'S.ByteString'. +headerEncodeBS :: HeaderEncode n a => sing n -> a -> Maybe S.ByteString +headerEncodeBS s = fmap Text.encodeUtf8 . headerEncode s + +-- | Interprets a (possibly missing) 'Text' representation for some value +-- taking semantics at a given 'HeaderName'. Any proxy can be passed as the +-- first argument, although 'Sing' is a nice one to choose. If a value is +-- expected and no representation is provided then 'Nothing' can be passed +-- seeking a default value (should one exist). +class HeaderDecode (n :: HeaderName) a where + headerDecode :: sing n -> Maybe Text -> Either String a + +-- | For a given concrete type @a@, a list of pairs @ts@ satisfies +-- @'AllHeaderDecode' a ts@ if each @(n, a)@ in @ts@ has @'HeaderDecode' +-- n a@. +type family AllHeaderDecodes hs :: Constraint where + AllHeaderDecodes '[] = () + AllHeaderDecodes ( '(n, a) ': hs ) = (HeaderDecode n a, AllHeaderDecodes hs) + +-- | While HTTP header semantics are built off of 'Text'-like values, we +-- usually read a raw 'S.ByteString' from the wire. This helper function +-- combines a 'HeaderDecode' with a UTF-8 decode so as to attempt to +-- deserialize header values directly from a 'S.ByteString'. +headerDecodeBS :: HeaderDecode n a => sing n -> Maybe S.ByteString -> Either String a +headerDecodeBS proxy mays = + case mays of + Nothing -> headerDecode proxy Nothing + Just s -> + case Text.decodeUtf8' s of + Left err -> Left (show err) + Right t -> headerDecode proxy (Just t) + +-- Instances/Encoding +-- ---------------------------------------------------------------------------- + +-- | Output a set of text items as a comma-delimited list OR return nothing +-- if the set is empty +displaySetOpt :: Set Text -> Maybe Text +displaySetOpt s + | Set.null s = Nothing + | otherwise = Just (Text.intercalate "," (Set.toList s)) + +-- | Extend a 'HeaderEncode' instance on @'Set' v@ to @[v]@. +uniqueSet :: (Ord v, HeaderEncode n (Set v)) => sing n -> [v] -> Maybe Text +uniqueSet s = headerEncode s . Set.fromList + +-- | Reports a "raw" value without interpretation +instance HeaderEncode n (Raw Text) where + headerEncode _ (Raw t) = Just t + +instance HeaderEncode 'Allow (Set Verb) where + headerEncode _ = displaySetOpt . Set.map verbName + +instance HeaderEncode 'Allow [Verb] where + headerEncode = uniqueSet + +instance HeaderEncode 'AccessControlExposeHeaders (Set SomeHeaderName) where + headerEncode _ = displaySetOpt . Set.map headerName' where + headerName' (SomeHeaderName h) = headerName h + +instance HeaderEncode 'AccessControlExposeHeaders [SomeHeaderName] where + headerEncode = uniqueSet + +instance HeaderEncode 'AccessControlAllowHeaders (Set SomeHeaderName) where + headerEncode _ = displaySetOpt . Set.map headerName' where + headerName' (SomeHeaderName h) = headerName h + +instance HeaderEncode 'AccessControlAllowHeaders [SomeHeaderName] where + headerEncode = uniqueSet + +instance HeaderEncode 'AccessControlMaxAge NominalDiffTime where + headerEncode _ ndt = Just $ Text.pack (show (round ndt :: Int)) + +instance HeaderEncode 'AccessControlAllowOrigin Text where + headerEncode _ org = Just org + +instance HeaderEncode 'AccessControlAllowMethods (Set Verb) where + headerEncode _ = displaySetOpt . Set.map verbName + +instance HeaderEncode 'AccessControlAllowMethods [Verb] where + headerEncode = uniqueSet + +instance HeaderEncode 'AccessControlAllowCredentials Bool where + headerEncode _ ok = Just (if ok then "true" else "false") + +instance HeaderEncode 'ContentType MediaType where + headerEncode _ mt = + case Text.decodeUtf8' (Media.renderHeader mt) of + Left _err -> Nothing + Right txt -> Just txt + +-- | Any value can be forced as optional if desired +instance HeaderEncode h t => HeaderEncode h (Maybe t) where + headerEncode p v = v >>= headerEncode p + +-- Instances/Decoding +-- ---------------------------------------------------------------------------- + +-- | Fail to decode if there is no header. For headers which lack default +-- values. If a header lacks a natural default then avoiding failure should +-- be /explicitly/ requested in the types by wrapping it with a 'Maybe'. +required :: (Text -> Either String a) -> Maybe Text -> Either String a +required _ Nothing = Left "missing header value" +required f (Just t) = f t + +-- | For headers with natural notions of default values. +withDefault :: a -> (Text -> Either String a) -> (Maybe Text -> Either String a) +withDefault def _ Nothing = Right def +withDefault _ f (Just a) = f a + +instance HeaderDecode Accept [Quality MediaType] where + headerDecode _ = withDefault [] parser where + parser txt = + case Media.parseQuality (Text.encodeUtf8 txt) of + Nothing -> Left "malformed accept header" + Just mts -> Right mts + +instance HeaderDecode ContentType MediaType where + headerDecode _ = required $ \txt -> + case Media.parseAccept (Text.encodeUtf8 txt) of + Nothing -> Left "malformed content type" + Just ct -> Right ct + +-- | Returns the raw header value +instance HeaderDecode n (Raw Text) where + headerDecode _ = required $ \text -> Right (Raw text) + +-- | Any value may be only optionally captured as desired +instance HeaderDecode h t => HeaderDecode h (Maybe t) where + headerDecode _ Nothing = Right Nothing + headerDecode p (Just t) = fmap Just (headerDecode p (Just t)) diff --git a/src/Network/HTTP/Kinder/MediaType.hs b/src/Network/HTTP/Kinder/MediaType.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/MediaType.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Unlike most other HTTP kinds descrbed in @http-kinder@, 'MediaType's +-- are special in that they're expected to be /very/ open to extension and +-- therefore are constrained only by kind @*@. +module Network.HTTP.Kinder.MediaType ( + + -- * Classes for encoding and decoding + HasMediaType (..) + , MimeEncode (..) + , MimeDecode (..) + + -- ** Listing constraints to type-level lists + , AllMimeEncode + , AllMimeDecode + + -- * Common content types + + , TextPlain + , JSON + + -- ** Content type modifiers + + , Ver (..) + + -- * Content negotiation + , negotiatedMimeEncode + , negotiatedMimeDecode + + -- ** Utilities for negotiation + , NegotiatedDecodeResult (..) + , encodersOf + , decodersOf + + -- * Re-exports from "Network.HTTP.Media" + , MediaType () + , mainType, subType, (/?), (/.) + , Quality () + +) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as Sl +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Proxy +import Data.Singletons +import Data.Singletons.Prelude.List (Sing (SCons, SNil)) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import GHC.Exts +import GHC.TypeLits +import Network.HTTP.Media (MediaType (), Quality (), + mainType, matchQuality, subType, + (/.), (//), (/:), (/?)) + +-- Encoding and decoding +-- ---------------------------------------------------------------------------- + +-- | Any Haskell type which instantiates 'HasMediaType' can be thought of +-- as a representative of that 'MediaType'. Users can construct their own +-- types and then instantiate 'HasMediaType' to extend the media type system. +class HasMediaType t where + mediaType :: sing t -> MediaType + +-- | 'MediaType's represent ways of encoding data as a bytestream---this +-- class encodes that representation. +class HasMediaType t => MimeEncode t a where + mimeEncode :: sing t -> a -> S.ByteString + +-- | 'MediaType's represent ways of encoding data as a bytestream---this +-- class provides parsers for this representation. +class HasMediaType t => MimeDecode t a where + mimeDecode :: sing t -> S.ByteString -> Either String a + +-- Special constraints +-- ---------------------------------------------------------------------------- + +-- | For a given concrete type @a@, a list of types @ts@ satisfies +-- @AllMimeEncode a ts@ if each @t@ in @ts@ has @'MimeEncode' t a@. +type family AllMimeEncode (a :: *) (ts :: [*]) :: Constraint where + AllMimeEncode a '[] = () + AllMimeEncode a (t ': ts) = (MimeEncode t a, AllMimeEncode a ts) + +-- | For a given concrete type @a@, a list of types @ts@ satisfies +-- @MAllMimeDecode a ts@ if each @t@ in @ts@ has @'MimeDecode' t a@. +type family AllMimeDecode (a :: *) (ts :: [*]) :: Constraint where + AllMimeDecode a '[] = () + AllMimeDecode a (t ': ts) = (MimeDecode t a, AllMimeDecode a ts) + +-- Content negotiation +-- ---------------------------------------------------------------------------- + +-- | Provided a 'Sing' representing a type-level list of mediatypes, +-- produce a concrete mapping from 'MediaType's to encoding functions. +encodersOf + :: AllMimeEncode a ts + => Sing ts -> Map MediaType (a -> S.ByteString) +encodersOf s = + case s of + SNil -> Map.empty + SCons r rs -> Map.insert (mediaType r) (mimeEncode r) (encodersOf rs) + +-- | Provided a 'Sing' representing a type-level list of mediatypes, +-- produce a concrete mapping from 'MediaType's to decoding functions. +decodersOf + :: AllMimeDecode a ts + => Sing ts -> Map MediaType (S.ByteString -> Either String a) +decodersOf s = + case s of + SNil -> Map.empty + SCons r rs -> Map.insert (mediaType r) (mimeDecode r) (decodersOf rs) + +-- | Encode a value using a list of valid media types and a list of +-- @Accept@able media types. If no provided media type is acceptable then +-- the first of the provided is chosen by default. If the valid media type +-- listing is empty then no encoder can be negotiated ever---we fail early. +negotiatedMimeEncode + :: AllMimeEncode a ts + => Sing ts + -> Maybe ([Quality MediaType] -> a -> (MediaType, S.ByteString)) +negotiatedMimeEncode SNil = Nothing +negotiatedMimeEncode valid@(SCons defaultMt _) = + -- This memoizes the construction of the encoders map so we do less + -- type-level list work. + Just (encode defaultEnc (Map.keys encoderMap) encoderMap) + where + encoderMap = encodersOf valid + defaultEnc = (mediaType defaultMt, mimeEncode defaultMt) + + encode (theDefaultMt, theDefaultEnc) provided theEncMap acceptable a = + maybe (theDefaultMt, theDefaultEnc a) id $ do + mt <- matchQuality provided acceptable + enc <- Map.lookup mt theEncMap + return (mt, enc a) + +-- | Negoatiated decodes can fail for two reasons: it could be that the +-- decoder failed (malformed input) or that the negotiation failed (a +-- content type was provided which isn't accepted by the server). +data NegotiatedDecodeResult a + = NegotiatedDecode a + | NegotiatedDecodeError String + | DecodeNegotiationFailure MediaType + deriving (Eq, Ord, Show) + +resultDecode :: Either String a -> NegotiatedDecodeResult a +resultDecode res = + case res of + Left err -> NegotiatedDecodeError err + Right val -> NegotiatedDecode val + +-- | Decode a value using a list of valid media types and (maybe) +-- a provided @Content-Type@ 'MediaType'. If the @Content-Type@ is not +-- provided then the decoder for the first valid content type is attempted. +-- If the valid media type listing is empty then no decoder could ever be +-- negotiated---we fail early. +negotiatedMimeDecode + :: AllMimeDecode a ts + => Sing ts + -> Maybe (Maybe MediaType -> S.ByteString -> NegotiatedDecodeResult a) +negotiatedMimeDecode SNil = Nothing +negotiatedMimeDecode valid@(SCons defaultMt _) = + -- This memoizes the construction of the decoders map so we do less + -- type-level list work. + Just (decode defaultDec decoderMap) + where + decoderMap = decodersOf valid + defaultDec = (mediaType defaultMt, mimeDecode defaultMt) + + decode (_theDefaultMt, theDefaultDec) theDecMap maybeCt bytes = + case maybeCt of + Nothing -> resultDecode (theDefaultDec bytes) + Just ct -> + case Map.lookup ct theDecMap of + Nothing -> DecodeNegotiationFailure ct + Just dec -> resultDecode (dec bytes) + +-- | Versions a media type using mime type parameterization. @'Ver' 1 JSON@ +-- has a media type like @"application/json; version=1"@. To use 'Ver' +-- create instances, e.g., for @'MimeEncode' ('Ver' n t) a@ which +-- specialize encoders for type @t@ +newtype Ver (n :: Nat) a = Ver { getVer :: a } + deriving (Eq, Ord, Show, Functor) + +instance Applicative (Ver n) where + pure = Ver + Ver f <*> Ver a = Ver (f a) + +instance Monad (Ver n) where + return = pure + Ver x >>= f = f x + +instance (HasMediaType t, KnownNat n) => HasMediaType (Ver n t) where + mediaType _ = mediaType (Proxy :: Proxy t) /: ("version", fromString (show (natVal (Proxy :: Proxy n)))) + +-- | The 'TextPlain' media type ("text/plain") is unformatted, raw text. +data TextPlain + +instance HasMediaType TextPlain where + mediaType _ = "text" // "plain" + +instance MimeEncode TextPlain Text where + mimeEncode _ = Text.encodeUtf8 + +-- | The 'JSON' media type ("application/json") is JSON formatted text. Any +-- Haskell type with 'Aeson.ToJSON' or 'Aeson.FromJSON' values can +-- participate. +data JSON + +instance HasMediaType JSON where + mediaType _ = "application" // "json" + +instance Aeson.ToJSON a => MimeEncode JSON a where + mimeEncode _ = Sl.toStrict . Aeson.encode + +instance Aeson.FromJSON a => MimeDecode JSON a where + mimeDecode _ bs = Aeson.eitherDecodeStrict bs diff --git a/src/Network/HTTP/Kinder/Query.hs b/src/Network/HTTP/Kinder/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/Query.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | A request can be thought of as having a query component which is +-- a mapping from a set of query keys (which are just strings) to values of +-- @'QueryKeyState' 'Text'@. +-- +-- This module provides tools for extracting information from this mapping +-- or constructing them. +module Network.HTTP.Kinder.Query ( + + -- * Classes for encoding and decoding + QueryEncode (..) + , QueryDecode (..) + + -- ** Listing constraints to type-level lists + + , AllQueryEncodes + , AllQueryDecodes + + -- ** Types for encoding/decoding request queries + , QueryKeyState (..) + , Flag (..) + + -- * Extra serialization utilities + , queryEncodePair + +) where + +import Control.Monad +import Data.Singletons.Prelude +import Data.Singletons.TypeLits +import Data.String +import Data.Text (Text) +import GHC.Exts +import Network.HTTP.Kinder.Common + +-- Data Types +-- ---------------------------------------------------------------------------- + +-- | 'Flag' provides semantics for query parameters which may merely exist +-- without actually storing a value---"flag" semantics. +data Flag = Here | NotHere + +-- | 'QueryKeyState' describes the state of a given key within a query-map. +-- The key may be complete absent, it may exist without a value, or it may +-- exist with some value at a given type. +data QueryKeyState a + = QueryKeyPresent + | QueryKeyValued a + | QueryKeyAbsent + deriving ( Eq, Ord, Show, Read, Functor ) + +instance Applicative QueryKeyState where + pure = QueryKeyValued + (<*>) = ap + +-- | Monad instance equivalent to @Either Bool@ +instance Monad QueryKeyState where + return = pure + m >>= f = + case m of + QueryKeyValued a -> f a + QueryKeyPresent -> QueryKeyPresent + QueryKeyAbsent -> QueryKeyAbsent + +-- Classes +-- ---------------------------------------------------------------------------- + +-- | Determines a representation of a query value for a given query key. +class QueryEncode (s :: Symbol) a where + queryEncode :: sing s -> a -> QueryKeyState Text + + +-- | For a given concrete type @a@, a list of pairs @ts@ satisfies +-- @'AllQueryEncode' a ts@ if each @(n, a)@ in @ts@ has @'QueryEncode' +-- n a@. +type family AllQueryEncodes hs :: Constraint where + AllQueryEncodes '[] = () + AllQueryEncodes ( '(s, a) ': hs ) = (QueryEncode s a, AllQueryEncodes hs) + + +-- | Attempts to parse a representation of a query value at a given query +-- key. +class QueryDecode (s :: Symbol) a where + queryDecode :: sing s -> QueryKeyState Text -> Either String a + +-- | For a given concrete type @a@, a list of pairs @ts@ satisfies +-- @'AllQueryDecode' a ts@ if each @(n, a)@ in @ts@ has @'QueryDecode' +-- n a@. +type family AllQueryDecodes hs :: Constraint where + AllQueryDecodes '[] = () + AllQueryDecodes ( '(s, a) ': hs ) = (QueryDecode s a, AllQueryDecodes hs) + + +-- | Produces a pair of @(name, representation)@ from a given query encoding. +queryEncodePair :: (KnownSymbol n, QueryEncode n a) => Sing n -> a -> Maybe (Text, Maybe Text) +queryEncodePair s a = + case queryEncode s a of + QueryKeyAbsent -> Nothing + QueryKeyPresent -> Just (name, Nothing) + QueryKeyValued v -> Just (name, Just v) + where + name = fromString (withKnownSymbol s (symbolVal s)) + +-- Instances +-- ---------------------------------------------------------------------------- + +instance QueryEncode s a => QueryEncode s (QueryKeyState a) where + queryEncode p v = v >>= queryEncode p + +instance QueryEncode s Flag where + queryEncode _ Here = QueryKeyPresent + queryEncode _ NotHere = QueryKeyAbsent + +instance QueryEncode s (Raw Text) where + queryEncode _ (Raw t) = QueryKeyValued t + +-- Handles the common case of an optional value. In other words, this will +-- treat a query parameter which was provided without a value as having +-- actually provided an empty value @""@. +instance QueryEncode s a => QueryEncode s (Maybe a) where + queryEncode _ Nothing = QueryKeyAbsent + queryEncode p (Just a) = + case queryEncode p a of + QueryKeyAbsent -> QueryKeyAbsent + QueryKeyPresent -> QueryKeyValued "" + QueryKeyValued txt -> QueryKeyValued txt + +instance QueryDecode s a => QueryDecode s (QueryKeyState a) where + queryDecode p v = + case v of + QueryKeyAbsent -> Right QueryKeyAbsent + QueryKeyPresent -> Right QueryKeyPresent + QueryKeyValued _ -> + case queryDecode p v of + Left err -> Left err + Right val -> Right (QueryKeyValued val) + +-- | This instance act "strictly" in that if the key is present but given +-- a value then it will fail to parse for this type. To be lenient use +-- 'QueryKeyState' directly. +instance QueryDecode s Flag where + queryDecode _ QueryKeyAbsent = Right NotHere + queryDecode _ QueryKeyPresent = Right Here + queryDecode _ QueryKeyValued {} = Left "expected a flag query param, found a value" + +instance QueryDecode s (Raw Text) where + queryDecode _ QueryKeyAbsent = Left "expected query key" + queryDecode _ QueryKeyPresent = Left "expected query value" + queryDecode _ (QueryKeyValued t) = Right (Raw t) + +instance QueryDecode s a => QueryDecode s (Maybe a) where + queryDecode _ QueryKeyAbsent = Right Nothing + queryDecode p QueryKeyPresent = queryDecode p (QueryKeyValued "") + queryDecode p (QueryKeyValued t) = fmap Just (queryDecode p (QueryKeyValued t)) diff --git a/src/Network/HTTP/Kinder/Status.hs b/src/Network/HTTP/Kinder/Status.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/Status.hs @@ -0,0 +1,563 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Defines the types and kinds for working with type and value level HTTP +-- status codes. +-- +-- In particular, this module exports a datatype, 'Status' which is meant +-- to be used with @DataKinds@ providing one type, e.g. ''Ok' for every +-- common HTTP response status (and an override one 'CustomStatus'). It +-- also exports 'Sing' values for each 'Status'-kinded type each merely +-- being the name of that type prepended with @S@. +-- +-- Finally, it exports a set of type synonms for each 'Status'-kinded type +-- so that they can be referenced without the quote prefix @'@. +module Network.HTTP.Kinder.Status ( + + -- * Functions and types for working with 'HeaderName' 'Sing's + SomeStatus (SomeStatus) + , httpStatus + , statusCode + , parseStatus + + -- * The 'Status' type/kind + , Status (..) + , Sing ( + SCustomStatus + , SContinue + , SSwitchingProtocols + , SOk + , SCreated + , SAccepted + , SNonAuthoritiveInformation + , SNoContent + , SResetContent + , SPartialContent + , SIMUsed + , SMultipleChoices + , SMovedPermanently + , SFound + , SSeeOther + , SNotModified + , STemporaryRedirect + , SPermanentRedirect + , SBadRequest + , SUnauthorized + , SPaymentRequired + , SForbidden + , SNotFound + , SMethodNotAllowed + , SNotAcceptable + , SProxyAuthenticationRequired + , SRequestTimeout + , SConflict + , SGone + , SLengthRequired + , SPreconditionFailed + , SPayloadTooLarge + , SRequestURITooLong + , SUnsupportedMediaType + , SRequestedRangeNotSatisfiable + , SExpectationFailed + , SMisdirectedRequest + , SUnprocessableEntity + , SLocked + , SFailedDependency + , SUpgradeRequired + , SPreconditionRequired + , STooManyRequests + , SRequestHeaderFieldsTooLarge + , SUnavailableForLegalReasons + , SInternalServerError + , SNotImplemented + , SBadGateway + , SServiceUnavailable + , SGatewayTimeout + , SHTTPVersionNotSupported + , SVariantAlsoNegotiates + , SInsufficientStorage + , SLoopDetected + , SNotExtended + , SNetworkAuthenticationRequired + ) + + -- * Type synonyms for more convenient use of 'Status'es + + , CustomStatus + , Continue + , SwitchingProtocols + , Ok + , Created + , Accepted + , NonAuthoritiveInformation + , NoContent + , ResetContent + , PartialContent + , IMUsed + , MultipleChoices + , MovedPermanently + , Found + , SeeOther + , NotModified + , TemporaryRedirect + , PermanentRedirect + , BadRequest + , Unauthorized + , PaymentRequired + , Forbidden + , NotFound + , MethodNotAllowed + , NotAcceptable + , ProxyAuthenticationRequired + , RequestTimeout + , Conflict + , Gone + , LengthRequired + , PreconditionFailed + , PayloadTooLarge + , RequestURITooLong + , UnsupportedMediaType + , RequestedRangeNotSatisfiable + , ExpectationFailed + , MisdirectedRequest + , UnprocessableEntity + , Locked + , FailedDependency + , UpgradeRequired + , PreconditionRequired + , TooManyRequests + , RequestHeaderFieldsTooLarge + , UnavailableForLegalReasons + , InternalServerError + , NotImplemented + , BadGateway + , ServiceUnavailable + , GatewayTimeout + , HTTPVersionNotSupported + , VariantAlsoNegotiates + , InsufficientStorage + , LoopDetected + , NotExtended + , NetworkAuthenticationRequired + +) where + +import Data.Singletons +import Data.Singletons.TypeLits +import qualified Network.HTTP.Types.Status as S + +-- | It's difficult to get ahold of values of 'Status' directly since they +-- may contain 'Nat' values which do not exist. Instead, we can get almost +-- the same effect through an existential which holds a singleton at the +-- 'Status' kind +-- +-- Note that while the Haddocks show this as taking any 'Sing' type it is +-- actually constrained only to have 'Sing's of kind 'Status'. +data SomeStatus where + SomeStatus :: forall (s :: Status) . Sing s -> SomeStatus + +-- | Convert a 'Status' 'Sing'-value into a normal @http-types@ 'S.Status' +httpStatus :: forall (sc :: Status) . Sing sc -> S.Status +httpStatus c = + case c of + SCustomStatus int -> S.mkStatus (fromInteger (withKnownNat int (natVal int))) "" + + 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 + +-- | Get the 'Int' status code for a given 'Status' 'Sing'. +statusCode :: forall (sc :: Status) . Sing sc -> Int +statusCode = S.statusCode . httpStatus + +-- | Given a particular 'Int' status create a 'Status' 'Sing' to match. +-- Attempts to parse to a meaningful 'Status' 'Sing' but defaults to +-- 'CustomStatus' if necessary. +parseStatus :: Int -> SomeStatus +parseStatus c = + case c of + 100 -> SomeStatus SContinue + 101 -> SomeStatus SSwitchingProtocols + + 200 -> SomeStatus SOk + 201 -> SomeStatus SCreated + 202 -> SomeStatus SAccepted + 204 -> SomeStatus SNoContent + 205 -> SomeStatus SResetContent + 206 -> SomeStatus SPartialContent + 226 -> SomeStatus SIMUsed + + 300 -> SomeStatus SMultipleChoices + 301 -> SomeStatus SMovedPermanently + 302 -> SomeStatus SFound + 303 -> SomeStatus SSeeOther + 304 -> SomeStatus SNotModified + 307 -> SomeStatus STemporaryRedirect + 308 -> SomeStatus SPermanentRedirect + + 400 -> SomeStatus SBadRequest + 401 -> SomeStatus SUnauthorized + 402 -> SomeStatus SPaymentRequired + 403 -> SomeStatus SForbidden + 404 -> SomeStatus SNotFound + 405 -> SomeStatus SMethodNotAllowed + 406 -> SomeStatus SNotAcceptable + 407 -> SomeStatus SProxyAuthenticationRequired + 408 -> SomeStatus SRequestTimeout + 409 -> SomeStatus SConflict + 410 -> SomeStatus SGone + 411 -> SomeStatus SLengthRequired + 412 -> SomeStatus SPreconditionFailed + 413 -> SomeStatus SPayloadTooLarge + 414 -> SomeStatus SRequestURITooLong + 415 -> SomeStatus SUnsupportedMediaType + 416 -> SomeStatus SRequestedRangeNotSatisfiable + 417 -> SomeStatus SExpectationFailed + 421 -> SomeStatus SMisdirectedRequest + 422 -> SomeStatus SUnprocessableEntity + 423 -> SomeStatus SLocked + 424 -> SomeStatus SFailedDependency + 426 -> SomeStatus SUpgradeRequired + 428 -> SomeStatus SPreconditionRequired + 429 -> SomeStatus STooManyRequests + 431 -> SomeStatus SRequestHeaderFieldsTooLarge + 451 -> SomeStatus SUnavailableForLegalReasons + + 500 -> SomeStatus SInternalServerError + 501 -> SomeStatus SNotImplemented + 502 -> SomeStatus SBadGateway + 503 -> SomeStatus SServiceUnavailable + 504 -> SomeStatus SGatewayTimeout + 505 -> SomeStatus SHTTPVersionNotSupported + 506 -> SomeStatus SVariantAlsoNegotiates + 507 -> SomeStatus SInsufficientStorage + 508 -> SomeStatus SLoopDetected + 510 -> SomeStatus SNotExtended + 511 -> SomeStatus SNetworkAuthenticationRequired + + other -> + case toSing (fromIntegral other) :: SomeSing ('KProxy :: KProxy Nat) of + SomeSing code -> SomeStatus (SCustomStatus code) + +-- | A data type representing HTTP statuses (codes). Much more importantly, +-- with @DataKinds@ enabled this becomes a kind describing types, one for +-- each such status. +-- +-- It's worth noting that values of this type can be had, but one branch, +-- 'CustomStatus' will not work since it requires 'Nat' values which cannot +-- be had. For this reason prefer using values of 'SomeStatus' instead of +-- values of 'Status' directly. +data Status + + ---- Custom codes + + = CustomStatus Nat + -- ^ Inject an arbitatry code number as a status code. + + ---- 1xx Informational + + | Continue + | SwitchingProtocols + + ---- 2xx Success + + | Ok + | Created + | Accepted + | NonAuthoritiveInformation + | NoContent + | ResetContent + | PartialContent + | IMUsed + + ---- 3xx Redirection + + | MultipleChoices + | MovedPermanently + | Found + | SeeOther + | NotModified + | TemporaryRedirect + | PermanentRedirect + + ---- 4xx Client Error + + | BadRequest + | Unauthorized + | PaymentRequired + | Forbidden + | NotFound + | MethodNotAllowed + | NotAcceptable + | ProxyAuthenticationRequired + | RequestTimeout + | Conflict + | Gone + | LengthRequired + | PreconditionFailed + | PayloadTooLarge + | RequestURITooLong + | UnsupportedMediaType + | RequestedRangeNotSatisfiable + | ExpectationFailed + | MisdirectedRequest + | UnprocessableEntity + | Locked + | FailedDependency + | UpgradeRequired + | PreconditionRequired + | TooManyRequests + | RequestHeaderFieldsTooLarge + | UnavailableForLegalReasons + + ---- 5xx Server Error + + | InternalServerError + | NotImplemented + | BadGateway + | ServiceUnavailable + | GatewayTimeout + | HTTPVersionNotSupported + | VariantAlsoNegotiates + | InsufficientStorage + | LoopDetected + | NotExtended + | NetworkAuthenticationRequired + +type CustomStatus code = 'CustomStatus code +type Continue = 'Continue +type SwitchingProtocols = 'SwitchingProtocols +type Ok = 'Ok +type Created = 'Created +type Accepted = 'Accepted +type NonAuthoritiveInformation = 'NonAuthoritiveInformation +type NoContent = 'NoContent +type ResetContent = 'ResetContent +type PartialContent = 'PartialContent +type IMUsed = 'IMUsed +type MultipleChoices = 'MultipleChoices +type MovedPermanently = 'MovedPermanently +type Found = 'Found +type SeeOther = 'SeeOther +type NotModified = 'NotModified +type TemporaryRedirect = 'TemporaryRedirect +type PermanentRedirect = 'PermanentRedirect +type BadRequest = 'BadRequest +type Unauthorized = 'Unauthorized +type PaymentRequired = 'PaymentRequired +type Forbidden = 'Forbidden +type NotFound = 'NotFound +type MethodNotAllowed = 'MethodNotAllowed +type NotAcceptable = 'NotAcceptable +type ProxyAuthenticationRequired = 'ProxyAuthenticationRequired +type RequestTimeout = 'RequestTimeout +type Conflict = 'Conflict +type Gone = 'Gone +type LengthRequired = 'LengthRequired +type PreconditionFailed = 'PreconditionFailed +type PayloadTooLarge = 'PayloadTooLarge +type RequestURITooLong = 'RequestURITooLong +type UnsupportedMediaType = 'UnsupportedMediaType +type RequestedRangeNotSatisfiable = 'RequestedRangeNotSatisfiable +type ExpectationFailed = 'ExpectationFailed +type MisdirectedRequest = 'MisdirectedRequest +type UnprocessableEntity = 'UnprocessableEntity +type Locked = 'Locked +type FailedDependency = 'FailedDependency +type UpgradeRequired = 'UpgradeRequired +type PreconditionRequired = 'PreconditionRequired +type TooManyRequests = 'TooManyRequests +type RequestHeaderFieldsTooLarge = 'RequestHeaderFieldsTooLarge +type UnavailableForLegalReasons = 'UnavailableForLegalReasons +type InternalServerError = 'InternalServerError +type NotImplemented = 'NotImplemented +type BadGateway = 'BadGateway +type ServiceUnavailable = 'ServiceUnavailable +type GatewayTimeout = 'GatewayTimeout +type HTTPVersionNotSupported = 'HTTPVersionNotSupported +type VariantAlsoNegotiates = 'VariantAlsoNegotiates +type InsufficientStorage = 'InsufficientStorage +type LoopDetected = 'LoopDetected +type NotExtended = 'NotExtended +type NetworkAuthenticationRequired = 'NetworkAuthenticationRequired + +-- ---------------------------------------------------------------------------- +-- These could be generated by TH, but we're inlining them! Not only is +-- this faster but it also properly handles the fact that there is no +-- reasonable 'DemoteRep' available +-- ---------------------------------------------------------------------------- + +data instance Sing (s :: Status) + = forall i . s ~ CustomStatus i => SCustomStatus (Sing i) + | s ~ Continue => SContinue + | s ~ SwitchingProtocols => SSwitchingProtocols + | s ~ Ok => SOk + | s ~ Created => SCreated + | s ~ Accepted => SAccepted + | s ~ NonAuthoritiveInformation => SNonAuthoritiveInformation + | s ~ NoContent => SNoContent + | s ~ ResetContent => SResetContent + | s ~ PartialContent => SPartialContent + | s ~ IMUsed => SIMUsed + | s ~ MultipleChoices => SMultipleChoices + | s ~ MovedPermanently => SMovedPermanently + | s ~ Found => SFound + | s ~ SeeOther => SSeeOther + | s ~ NotModified => SNotModified + | s ~ TemporaryRedirect => STemporaryRedirect + | s ~ PermanentRedirect => SPermanentRedirect + | s ~ BadRequest => SBadRequest + | s ~ Unauthorized => SUnauthorized + | s ~ PaymentRequired => SPaymentRequired + | s ~ Forbidden => SForbidden + | s ~ NotFound => SNotFound + | s ~ MethodNotAllowed => SMethodNotAllowed + | s ~ NotAcceptable => SNotAcceptable + | s ~ ProxyAuthenticationRequired => SProxyAuthenticationRequired + | s ~ RequestTimeout => SRequestTimeout + | s ~ Conflict => SConflict + | s ~ Gone => SGone + | s ~ LengthRequired => SLengthRequired + | s ~ PreconditionFailed => SPreconditionFailed + | s ~ PayloadTooLarge => SPayloadTooLarge + | s ~ RequestURITooLong => SRequestURITooLong + | s ~ UnsupportedMediaType => SUnsupportedMediaType + | s ~ RequestedRangeNotSatisfiable => SRequestedRangeNotSatisfiable + | s ~ ExpectationFailed => SExpectationFailed + | s ~ MisdirectedRequest => SMisdirectedRequest + | s ~ UnprocessableEntity => SUnprocessableEntity + | s ~ Locked => SLocked + | s ~ FailedDependency => SFailedDependency + | s ~ UpgradeRequired => SUpgradeRequired + | s ~ PreconditionRequired => SPreconditionRequired + | s ~ TooManyRequests => STooManyRequests + | s ~ RequestHeaderFieldsTooLarge => SRequestHeaderFieldsTooLarge + | s ~ UnavailableForLegalReasons => SUnavailableForLegalReasons + | s ~ InternalServerError => SInternalServerError + | s ~ NotImplemented => SNotImplemented + | s ~ BadGateway => SBadGateway + | s ~ ServiceUnavailable => SServiceUnavailable + | s ~ GatewayTimeout => SGatewayTimeout + | s ~ HTTPVersionNotSupported => SHTTPVersionNotSupported + | s ~ VariantAlsoNegotiates => SVariantAlsoNegotiates + | s ~ InsufficientStorage => SInsufficientStorage + | s ~ LoopDetected => SLoopDetected + | s ~ NotExtended => SNotExtended + | s ~ NetworkAuthenticationRequired => SNetworkAuthenticationRequired + +instance SingI i => SingI ('CustomStatus i) where sing = SCustomStatus sing +instance SingI 'Continue where sing = SContinue +instance SingI 'SwitchingProtocols where sing = SSwitchingProtocols +instance SingI 'Ok where sing = SOk +instance SingI 'Created where sing = SCreated +instance SingI 'Accepted where sing = SAccepted +instance SingI 'NonAuthoritiveInformation where sing = SNonAuthoritiveInformation +instance SingI 'NoContent where sing = SNoContent +instance SingI 'ResetContent where sing = SResetContent +instance SingI 'PartialContent where sing = SPartialContent +instance SingI 'IMUsed where sing = SIMUsed +instance SingI 'MultipleChoices where sing = SMultipleChoices +instance SingI 'MovedPermanently where sing = SMovedPermanently +instance SingI 'Found where sing = SFound +instance SingI 'SeeOther where sing = SSeeOther +instance SingI 'NotModified where sing = SNotModified +instance SingI 'TemporaryRedirect where sing = STemporaryRedirect +instance SingI 'PermanentRedirect where sing = SPermanentRedirect +instance SingI 'BadRequest where sing = SBadRequest +instance SingI 'Unauthorized where sing = SUnauthorized +instance SingI 'PaymentRequired where sing = SPaymentRequired +instance SingI 'Forbidden where sing = SForbidden +instance SingI 'NotFound where sing = SNotFound +instance SingI 'MethodNotAllowed where sing = SMethodNotAllowed +instance SingI 'NotAcceptable where sing = SNotAcceptable +instance SingI 'ProxyAuthenticationRequired where sing = SProxyAuthenticationRequired +instance SingI 'RequestTimeout where sing = SRequestTimeout +instance SingI 'Conflict where sing = SConflict +instance SingI 'Gone where sing = SGone +instance SingI 'LengthRequired where sing = SLengthRequired +instance SingI 'PreconditionFailed where sing = SPreconditionFailed +instance SingI 'PayloadTooLarge where sing = SPayloadTooLarge +instance SingI 'RequestURITooLong where sing = SRequestURITooLong +instance SingI 'UnsupportedMediaType where sing = SUnsupportedMediaType +instance SingI 'RequestedRangeNotSatisfiable where sing = SRequestedRangeNotSatisfiable +instance SingI 'ExpectationFailed where sing = SExpectationFailed +instance SingI 'MisdirectedRequest where sing = SMisdirectedRequest +instance SingI 'UnprocessableEntity where sing = SUnprocessableEntity +instance SingI 'Locked where sing = SLocked +instance SingI 'FailedDependency where sing = SFailedDependency +instance SingI 'UpgradeRequired where sing = SUpgradeRequired +instance SingI 'PreconditionRequired where sing = SPreconditionRequired +instance SingI 'TooManyRequests where sing = STooManyRequests +instance SingI 'RequestHeaderFieldsTooLarge where sing = SRequestHeaderFieldsTooLarge +instance SingI 'UnavailableForLegalReasons where sing = SUnavailableForLegalReasons +instance SingI 'InternalServerError where sing = SInternalServerError +instance SingI 'NotImplemented where sing = SNotImplemented +instance SingI 'BadGateway where sing = SBadGateway +instance SingI 'ServiceUnavailable where sing = SServiceUnavailable +instance SingI 'GatewayTimeout where sing = SGatewayTimeout +instance SingI 'HTTPVersionNotSupported where sing = SHTTPVersionNotSupported +instance SingI 'VariantAlsoNegotiates where sing = SVariantAlsoNegotiates +instance SingI 'InsufficientStorage where sing = SInsufficientStorage +instance SingI 'LoopDetected where sing = SLoopDetected +instance SingI 'NotExtended where sing = SNotExtended +instance SingI 'NetworkAuthenticationRequired where sing = SNetworkAuthenticationRequired diff --git a/src/Network/HTTP/Kinder/URI.hs b/src/Network/HTTP/Kinder/URI.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/URI.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Network.HTTP.Kinder.URI ( + + -- * Classes for encoding and decoding + URIEncode (..) + , URIDecode (..) + + -- * Extra serialization utilities + , uriDecodeBS + +) where + +import qualified Data.ByteString as S +import Data.Int +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Enc +import Data.Text.Read (decimal) +import Network.HTTP.Kinder.Common + +-- Class +-- ---------------------------------------------------------------------------- + +-- | Determines a 'Text' serialization of a type with URI segment +-- representation. +class URIEncode a where + uriEncode :: a -> Text + +-- | Parses a 'Text' serialization of a for some type from a representation +-- as a URI segment. +class URIDecode a where + uriDecode :: Text -> Either String a + +-- | Since 'URIDecode' assumes a 'Text'-like representation but we may read +-- a 'S.ByteString' off the wire, this helper function first tries to +-- decode the 'S.ByteString' as UTF-8 'Text' then decodes according to +-- 'URIDecode'. +uriDecodeBS :: URIDecode a => S.ByteString -> Either String a +uriDecodeBS s = case Enc.decodeUtf8' s of + Left _err -> Left "could not parse UTF8 string" + Right a -> uriDecode a + +-- Instances +-- ---------------------------------------------------------------------------- + +instance URIDecode (Raw Text) where + uriDecode text = Right (Raw text) + +-- | For URI segments this instance is the same as the one for @'Raw' +-- 'Text'@ since URI segments don't contain quotations. +instance URIDecode Text where + uriDecode text = Right text + +-- | Decoder for any type with a decimal representation. Requires a 'Show' +-- instance for the error message. +uriDecodeDecimal :: (Show a, Integral a) => Text -> Either String a +uriDecodeDecimal txt = + case decimal txt of + Left err -> Left err + Right (a, t) + | Text.null t -> Right a + | otherwise -> Left ("incomplete parse: " ++ show (a, t)) + +instance URIDecode Int where uriDecode = uriDecodeDecimal +instance URIDecode Int8 where uriDecode = uriDecodeDecimal +instance URIDecode Int16 where uriDecode = uriDecodeDecimal +instance URIDecode Int32 where uriDecode = uriDecodeDecimal +instance URIDecode Int64 where uriDecode = uriDecodeDecimal +instance URIDecode Integer where uriDecode = uriDecodeDecimal diff --git a/src/Network/HTTP/Kinder/Verb.hs b/src/Network/HTTP/Kinder/Verb.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Kinder/Verb.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Defines types and kinds for working with type and value level HTTP +-- verbs. +module Network.HTTP.Kinder.Verb ( + + -- * Functions and types for working with 'HeaderName' 'Sing's + verbName + , parseVerb + + -- * The 'Verb' type/kind + , Verb (..) + , Sing ( SDELETE, SGET, SHEAD, SOPTIONS, SPATCH, SPOST, SPUT ) + + -- * Type synonyms for more convenient use of 'HeaderName's + + , DELETE + , GET + , HEAD + , OPTIONS + , PATCH + , POST + , PUT + +) where + +import qualified Data.ByteString as S +import qualified Data.CaseInsensitive as CI +import Data.Singletons.Prelude +import Data.String + +-- | A data type representing HTTP verbs. Much more importantly, with +-- @DataKinds@ enabled this becomes a kind describing types, one for each +-- such verb. +-- +-- Use 'Verb' at both the kind and type levels---it works equally well at +-- both unlike, e.g., 'HeaderName'. Use methods of 'SingKind' to convert +-- between 'Verb' values and 'Verb' 'Sing's +-- +-- Note: TRACE is intentionally omitted because (a) it's very low value and +-- (b) it opens a potential security hole via Cross-Site-Tracing. +data Verb + = DELETE + | GET + | HEAD + | OPTIONS + | PATCH + | POST + | PUT + deriving ( Eq, Ord, Show, Read ) + +type DELETE = 'DELETE +type GET = 'GET +type HEAD = 'HEAD +type OPTIONS = 'OPTIONS +type PATCH = 'PATCH +type POST = 'POST +type PUT = 'PUT + +data instance Sing (v :: Verb) + = v ~ DELETE => SDELETE + | v ~ GET => SGET + | v ~ HEAD => SHEAD + | v ~ OPTIONS => SOPTIONS + | v ~ PATCH => SPATCH + | v ~ POST => SPOST + | v ~ PUT => SPUT + +instance SingI 'DELETE where sing = SDELETE +instance SingI 'GET where sing = SGET +instance SingI 'HEAD where sing = SHEAD +instance SingI 'OPTIONS where sing = SOPTIONS +instance SingI 'PATCH where sing = SPATCH +instance SingI 'POST where sing = SPOST +instance SingI 'PUT where sing = SPUT + +instance SingKind ('KProxy :: KProxy Verb) where + type DemoteRep ('KProxy :: KProxy Verb) = Verb + fromSing s = + case s of + SDELETE -> DELETE + SGET -> GET + SHEAD -> HEAD + SOPTIONS -> OPTIONS + SPATCH -> PATCH + SPOST -> POST + SPUT -> PUT + toSing v = + case v of + DELETE -> SomeSing SDELETE + GET -> SomeSing SGET + HEAD -> SomeSing SHEAD + OPTIONS -> SomeSing SOPTIONS + PATCH -> SomeSing SPATCH + POST -> SomeSing SPOST + PUT -> SomeSing SPUT + +-- | Convert a 'Verb' to its string-like representation +verbName :: IsString t => Verb -> t +verbName v = + case v of + GET -> "GET" + HEAD -> "HEAD" + POST -> "POST" + PUT -> "PUT" + PATCH -> "PATCH" + DELETE -> "DELETE" + OPTIONS -> "OPTIONS" + +-- | Attempt to parse a string-like representation of a 'Verb'. +parseVerb :: S.ByteString -> Maybe Verb +parseVerb s = + case CI.mk s of + "GET" -> Just GET + "HEAD" -> Just HEAD + "POST" -> Just POST + "PUT" -> Just PUT + "PATCH" -> Just PATCH + "DELETE" -> Just DELETE + "OPTIONS" -> Just OPTIONS + _ -> Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,31 @@ + +import Test.Tasty +import qualified Test.Tasty.HUnit as Hu +import Test.Tasty.Ingredients.Basic (consoleTestReporter, + listingTests) +import Test.Tasty.Runners.AntXML (antXMLRunner) +import Test.HUnit +import qualified Test.Network.HTTP.Kinder.URI as URI + +main :: IO () +main = + defaultMainWithIngredients + [ antXMLRunner + , listingTests + , consoleTestReporter + ] tests + +tests :: TestTree +tests = + testGroup "Server Tests" + [ systemTests + , URI.tests + ] + +systemTests :: TestTree +systemTests = testGroup "System Tests" + [ Hu.testCase "Trivial tests" trivial + ] where + +trivial :: Assertion +trivial = assertBool "True is False" True diff --git a/test/Test/Network/HTTP/Kinder/URI.hs b/test/Test/Network/HTTP/Kinder/URI.hs new file mode 100644 --- /dev/null +++ b/test/Test/Network/HTTP/Kinder/URI.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Network.HTTP.Kinder.URI where + +import Data.Proxy +import qualified Data.Text as Text +import Network.HTTP.Kinder.URI +import Test.HUnit +import Test.Tasty +import qualified Test.Tasty.HUnit as Hu + +tests :: TestTree +tests = + testGroup "URI Serialization" + [ testGroup "Decoding" + [ testGroup "Int" $ testDecodeDecimal (Proxy :: Proxy Int) + , testGroup "Integer" $ testDecodeDecimal (Proxy :: Proxy Integer) + ] + ] + +testDecodeDecimal :: (URIDecode a, Num a, Show a, Eq a) => Proxy a -> [TestTree] +testDecodeDecimal p = + [ Hu.testCase "decode simple correct examples" $ do + testParse "3" 3 + testParse "3000" 3000 + testParse "9999" 9999 + testParse "0000" 0 + , Hu.testCase "fail to decode simple incorrect examples" $ do + testNoParse "123abc" + testNoParse "abc123" + testNoParse "" + testNoParse "foobar" + ] + + where + testParse text val = + assertEqual + ("Value '" ++ text ++ "' parses") + (Right (val `asProxyTypeOf` p)) + (uriDecode (Text.pack text)) + testNoParse text = + case uriDecode (Text.pack text) of + Left _err -> assert True + Right v -> + assertFailure + ("successfully parsed bad value: " ++ text ++ " as " ++ show (v `asProxyTypeOf` p)) +