http-kinder (empty) → 0.2.0.0

raw patch · 15 files changed

+2593/−0 lines, 15 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, base, bytestring, case-insensitive, containers, http-kinder, http-media, http-types, singletons, tasty, tasty-ant-xml, tasty-hunit, tasty-quickcheck, text, time, wai, wai-extra

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• http-kinder.cabal +73/−0
• src/Network/HTTP/Kinder.hs +20/−0
• src/Network/HTTP/Kinder/Common.hs +14/−0
• src/Network/HTTP/Kinder/Header.hs +32/−0
• src/Network/HTTP/Kinder/Header/Definitions.hs +974/−0
• src/Network/HTTP/Kinder/Header/Serialization.hs +215/−0
• src/Network/HTTP/Kinder/MediaType.hs +227/−0
• src/Network/HTTP/Kinder/Query.hs +166/−0
• src/Network/HTTP/Kinder/Status.hs +563/−0
• src/Network/HTTP/Kinder/URI.hs +70/−0
• src/Network/HTTP/Kinder/Verb.hs +129/−0
• test/Spec.hs +31/−0
• test/Test/Network/HTTP/Kinder/URI.hs +47/−0

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <me@jspha.com>+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

@@ -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

@@ -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)

@@ -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)+

@@ -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: <delta-seconds>++  | 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: <method>[, <method>]*++  | 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: </feed>; 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

@@ -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))

@@ -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

@@ -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))

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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))+