serv (empty) → 0.1.0.0

raw patch · 33 files changed

+2908/−0 lines, 33 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, base, bytestring, case-insensitive, containers, http-media, http-types, mtl, serv, tagged, tasty, tasty-ant-xml, tasty-hunit, tasty-quickcheck, text, time, transformers, wai, wai-extra, warp

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• app/TestServer.hs +42/−0
• serv.cabal +97/−0
• src/Serv/Api.hs +15/−0
• src/Serv/Common.hs +4/−0
• src/Serv/ContentType.hs +43/−0
• src/Serv/Cors.hs +17/−0
• src/Serv/Header.hs +12/−0
• src/Serv/Header/Proxies.hs +75/−0
• src/Serv/Internal/Api.hs +106/−0
• src/Serv/Internal/Api/Analysis.hs +110/−0
• src/Serv/Internal/Cors.hs +127/−0
• src/Serv/Internal/Header.hs +64/−0
• src/Serv/Internal/Header/Name.hs +725/−0
• src/Serv/Internal/Header/Serialization.hs +130/−0
• src/Serv/Internal/MediaType.hs +86/−0
• src/Serv/Internal/Pair.hs +11/−0
• src/Serv/Internal/Query.hs +50/−0
• src/Serv/Internal/RawText.hs +16/−0
• src/Serv/Internal/Rec.hs +52/−0
• src/Serv/Internal/Server.hs +319/−0
• src/Serv/Internal/Server/Config.hs +8/−0
• src/Serv/Internal/Server/Context.hs +178/−0
• src/Serv/Internal/Server/Error.hs +17/−0
• src/Serv/Internal/Server/Type.hs +221/−0
• src/Serv/Internal/URI.hs +21/−0
• src/Serv/Internal/Verb.hs +42/−0
• src/Serv/Server.hs +44/−0
• src/Serv/URI.hs +9/−0
• test/Examples/Ex1.hs +111/−0
• test/Examples/Ex2.hs +91/−0
• test/Spec.hs +33/−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,42 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TypeOperators         #-}++import           Data.Function            ((&))+import           Data.Proxy+import           Data.Text                (Text)+import           Network.Wai.Handler.Warp (run)+import qualified Serv.Api                 as A+import           Serv.Common+import qualified Serv.ContentType         as Ct+import qualified Serv.Cors                as Cors+import qualified Serv.Header              as H+import qualified Serv.Header.Proxies      as Hp+import           Serv.Server++type RawBody = 'A.Body '[ Ct.TextPlain ] Text++type Api+  = 'A.Cors Cors.PermitAll 'A.:>+    'A.Endpoint+      '[ 'A.Method 'A.GET '[ 'H.CacheControl 'A.::: RawText ] RawBody ]++apiProxy :: Proxy Api+apiProxy = Proxy++impl :: Impl Api IO+impl = get :<|> noOp+  where+    get =+      return+      $ emptyResponse ok200+      & withHeader Hp.cacheControl "foo"+      & withBody "Hello"++server :: Server IO+server = handle apiProxy impl++main :: IO ()+main =+  run 8000 (makeApplication defaultConfig server)

@@ -0,0 +1,97 @@+name:                serv+version:             0.1.0.0+synopsis:            Dependently typed API server framework+description:         Please see README.md+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:++    Serv.Api+    Serv.Common+    Serv.ContentType+    Serv.Cors+    Serv.Header+    Serv.Header.Proxies+    Serv.URI+    Serv.Internal.Api+    Serv.Internal.Api.Analysis+    Serv.Internal.Cors+    Serv.Internal.Header+    Serv.Internal.Header.Name+    Serv.Internal.Header.Serialization+    Serv.Internal.MediaType+    Serv.Internal.Pair+    Serv.Internal.Query+    Serv.Internal.RawText+    Serv.Internal.Rec+    Serv.Internal.Server+    Serv.Internal.Server.Config+    Serv.Internal.Server.Context+    Serv.Internal.Server.Error+    Serv.Internal.Server.Type+    Serv.Internal.URI+    Serv.Internal.Verb+    Serv.Server++  build-depends:       base >= 4.7 && < 5+                     , aeson+                     , bytestring+                     , case-insensitive+                     , containers+                     , http-media+                     , http-types+                     , mtl+                     , tagged+                     , text+                     , time+                     , transformers+                     , wai+  default-language:    Haskell2010++executable test-server+  hs-source-dirs:      app+  main-is:             TestServer.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , serv+                     , wai+                     , warp+                     , text+  default-language:    Haskell2010++test-suite serv-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  other-modules:+    Examples.Ex1+    Examples.Ex2+  build-depends:       base+                     , serv++                     , 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/githubuser/serv

@@ -0,0 +1,15 @@++module Serv.Api (++    Api (..)+  , Method (..)+  , Body (..)+  , Path (..)+  , Verb (..)+  , Pair (..)++  ) where++import Serv.Internal.Api+import Serv.Internal.Verb+import Serv.Internal.Pair

@@ -0,0 +1,4 @@++module Serv.Common ( RawText (..) ) where++import Serv.Internal.RawText

@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}++module Serv.ContentType (++    HasMediaType (..)+  , MimeEncode (..)+  , MimeDecode (..)+  , (//)+  , (/:)++    -- Standard Content Types+  , TextPlain+  , JSON++  ) where++import qualified Data.Aeson              as A+import qualified Data.ByteString.Lazy    as Sl+import           Data.Text               (Text)+import qualified Data.Text.Encoding      as Text+import           Network.HTTP.Media+import           Serv.Internal.MediaType++data TextPlain++instance HasMediaType TextPlain where+  mediaType _ = "text" // "plain"++instance MimeEncode TextPlain Text where+  mimeEncode _ = Text.encodeUtf8++data JSON++instance HasMediaType JSON where+  mediaType _ = "application" // "json"++instance A.ToJSON a => MimeEncode JSON a where+  mimeEncode _ = Sl.toStrict . A.encode++instance A.FromJSON a => MimeDecode JSON a where+  mimeDecode _ bs = A.eitherDecodeStrict bs

@@ -0,0 +1,17 @@++module Serv.Cors (++    Policy+  , Context (..)+  , AccessSet (..)++  , CorsPolicy (..)+  , PermitAll++  , permitAll+  , wildcard+  , predicateWhitelist++  ) where++import Serv.Internal.Cors

@@ -0,0 +1,12 @@++module Serv.Header (++    HeaderName (..)+  , HeaderEncode (..)+  , HeaderDecode (..)+  , ReflectName++  ) where++import Serv.Internal.Header.Name+import Serv.Internal.Header.Serialization

@@ -0,0 +1,75 @@++module Serv.Header.Proxies (++    Proxy (..)+  , cacheControl+  , connection+  , contentLength+  , contentType+  , date+  , pragma+  , upgrade+  , via+  , warning+  , accept+  , acceptCharset+  , acceptEncoding+  , acceptLanguage+  , accessControlRequestMethod+  , accessControlRequestHeaders+  , authorization+  , cookie+  , expect+  , from+  , host+  , ifMatch+  , ifModifiedSince+  , ifNoneMatch+  , ifRange+  , ifUnmodifiedSince+  , maxForwards+  , origin+  , proxyAuthorization+  , range+  , referer+  , tE+  , userAgent+  , xForwardedFor+  , xForwardedHost+  , xForwardedProto+  , xCsrfToken+  , accessControlAllowOrigin+  , accessControlExposeHeaders+  , accessControlMaxAge+  , accessControlAllowCredentials+  , accessControlAllowMethods+  , accessControlAllowHeaders+  , acceptPatch+  , acceptRanges+  , age+  , allow+  , contentDisposition+  , contentEncoding+  , contentLanguage+  , contentLocation+  , contentRange+  , contentSecurityPolicy+  , eTag+  , expires+  , lastModified+  , link+  , location+  , proxyAuthenticate+  , publicKeyPins+  , retryAfter+  , setCookie+  , strictTransportSecurity+  , trailer+  , transferEncoding+  , vary+  , wWWAuthenticate++  ) where++import           Data.Proxy+import           Serv.Internal.Header.Name

@@ -0,0 +1,106 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++-- | Types, but really kinds, which represent the structure of an API.+module Serv.Internal.Api where++import           GHC.TypeLits+import           Serv.Internal.Header (HeaderName)+import           Serv.Internal.Pair+import           Serv.Internal.Verb+++-- | 'Api's describe collections of HTTP endpoints accessible at+-- various segmented 'Path's.+--+-- An 'Endpoint' describes a root API which responds+-- only to requests with empty paths. It matches on HTTP 'Method's+-- which demand 'Verb's, 'HeaderName's, and 'Body's.+--+-- 'Endpoint' differs from 'OneOf' in that it can only choose between+-- possible methods and automatically provides an 'OPTIONS' response.+--+-- 'Api's consist of many sub-'Api's which are attempted sequentially.+-- @'OneOf' choices@ expresses this sequential search along a set of sub-'Api'+-- @choices@.+--+-- 'Raw' enables the use of standard 'Wai.Application's within an 'Api'.+-- These cannot be examined further through type analysis, but they are a+-- common use case.+--+-- Qualify an API using a series of 'Path' qualifiers.+data Api star where+  Endpoint :: [Method star] -> Api star+  OneOf :: [Api star] -> Api star+  Raw :: Api star+  (:>) :: Path star -> Api star -> Api star++infixr 5 :>++-- | A 'Method' is a single HTTP verb response handled at a given 'Endpoint'.+-- In order to complete a 'Method''s operation it may demand data from the+-- request such as headers or the request body.+--+-- A "core" 'Method' definition which describes the 'Verb' it responds+-- to along with a set of response headers and a chance to attach a+-- response 'Body'.+--+-- Augment a 'Method' to include requirements of a request body.+--+-- Augment a 'Method' to include requirements of request header values.+--+data Method star where+  Method :: Verb -> [Pair HeaderName star] -> Body star -> Method star+  CaptureBody :: [star] -> star -> Method star -> Method star+  CaptureHeaders :: [Pair HeaderName star] -> Method star -> Method star+  CaptureQuery :: [Pair Symbol star] -> Method star -> Method star++-- | 'Method' responses may opt to include a response body or not.+--+-- Return a response body by specifying a set of content-types+-- and a value to derive the body from.+--+-- A response with an empty body+data Body star where+  Body :: [star] -> star -> Body star+  Empty :: Body star++-- | "Generalized" path segments match against data in the request.+--+-- Matches if the request has a non-empty remaining path and+-- the next segment matches exactly+--+-- Matches if the request has a given header and its value+-- matches exactly (!)+--+-- Matches if the request has a non-empty remaining path.+-- The next segment is "captured", provided to the server implementation.+--+-- Always matches, "capturing" the value of a header, or 'Nothing' if+-- the header fails to exist.+--+-- Always matches, "captures" the remaining path segments as a list+-- of text values. May just capture the empty list.+--+-- Always matches, "captures" the existence of a query flag by+-- returning 'True' if the flag is provided and 'False' otherwise.+--+-- Always matches, "capturing" the value of a query parameter.+data Path star where+  Const :: Symbol -> Path star+  HeaderAs :: HeaderName -> Symbol -> Path star+  Seg :: Symbol -> star -> Path star+  Header :: HeaderName -> star -> Path star+  Wildcard :: Path star+  Flag :: Symbol -> Path star+  QueryParam :: Symbol -> star -> Path star+  Cors :: star -> Path star

@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++-- | Typeclasses constructing functions which reflect and analyze API+-- types.+module Serv.Internal.Api.Analysis where++import           Data.Function        ((&))+import           Data.Monoid+import           Data.Proxy+import           Data.Set             (Set)+import qualified Data.Set             as Set+import qualified Network.HTTP.Types   as HTTP+import           Serv.Internal.Api+import qualified Serv.Internal.Header as Header+import qualified Serv.Internal.Verb   as Verb++class VerbsOf methods where+  verbsOf :: Proxy methods -> Set Verb.Verb++instance VerbsOf '[] where+  verbsOf Proxy = Set.singleton Verb.OPTIONS++instance+  (Verb.ReflectVerb verb, VerbsOf methods) =>+    VerbsOf ('Method verb headers body ': methods)+  where+    verbsOf Proxy =+      case Verb.reflectVerb (Proxy :: Proxy verb) of+        Verb.GET ->+          verbsOf (Proxy :: Proxy methods)+          & Set.insert Verb.GET+          & Set.insert Verb.HEAD+        verb -> Set.insert verb (verbsOf (Proxy :: Proxy methods))++class HeadersExpectedOf (methods :: [Method *]) where+  headersExpectedOf :: Proxy methods -> Set HTTP.HeaderName++instance HeadersExpectedOf '[] where+  headersExpectedOf _ = Set.empty++instance+  HeadersExpectedOf rs => HeadersExpectedOf ('Method verb headers body ': rs)+  where+    -- No headers are expected from a bottom method+    headersExpectedOf _ = headersExpectedOf (Proxy :: Proxy rs)++instance+  (HeadersExpectedOf (method ': rs), Header.ReflectHeaderNames hdrs) =>+  HeadersExpectedOf ('CaptureHeaders hdrs method ': rs)+  where+    headersExpectedOf _ =+      Set.fromList (Header.reflectHeaderNames (Proxy :: Proxy hdrs))+      <>+      headersExpectedOf (Proxy :: Proxy (method ': rs))++instance+  HeadersExpectedOf (method ': rs) =>+  HeadersExpectedOf ('CaptureBody ctypes ty method ': rs)+  where+    headersExpectedOf _ =+      headersExpectedOf (Proxy :: Proxy (method ': rs))++instance+  HeadersExpectedOf (method ': rs) =>+  HeadersExpectedOf ('CaptureQuery names method ': rs)+  where+    headersExpectedOf _ =+      headersExpectedOf (Proxy :: Proxy (method ': rs))++class HeadersReturnedBy (methods :: [Method *]) where+  headersReturnedBy :: Proxy methods -> Set HTTP.HeaderName++instance HeadersReturnedBy '[] where+  headersReturnedBy _ = Set.empty++instance+  (Header.ReflectHeaderNames headers, HeadersReturnedBy rs) =>+  HeadersReturnedBy ('Method verb headers body ': rs)+  where+    headersReturnedBy _ =+      Set.fromList (Header.reflectHeaderNames (Proxy :: Proxy headers))+      <>+      headersReturnedBy (Proxy :: Proxy rs)++instance+  HeadersReturnedBy (method ': rs) =>+  HeadersReturnedBy ('CaptureHeaders hdrs method ': rs)+  where+    headersReturnedBy _ =+      headersReturnedBy (Proxy :: Proxy (method ': rs))++instance+  HeadersReturnedBy (method ': rs) =>+  HeadersReturnedBy ('CaptureBody ctypes ty method ': rs)+  where+    headersReturnedBy _ =+      headersReturnedBy (Proxy :: Proxy (method ': rs))++instance+  HeadersReturnedBy (method ': rs) =>+  HeadersReturnedBy ('CaptureQuery names method ': rs)+  where+    headersReturnedBy _ =+      headersReturnedBy (Proxy :: Proxy (method ': rs))

@@ -0,0 +1,127 @@++module Serv.Internal.Cors where++import           Control.Applicative+import           Control.Monad+import           Data.Maybe                         (catMaybes)+import           Data.Monoid+import           Data.Proxy+import           Data.Set                           (Set)+import           Data.Text                          (Text)+import           Data.Time+import qualified Network.HTTP.Types                 as HTTP+import qualified Serv.Header.Proxies                as Hp+import qualified Serv.Internal.Header.Serialization as Hs+import           Serv.Internal.Server.Config+import           Serv.Internal.Verb                 (Verb)++-- | A 'CorsPolicy' interprets the request's provided Origin and the+-- current routing context to determine how to expose resources to the+-- requestor.+type Policy = Config -> Context -> AccessSet++-- | Class describing types which describe CORS 'Policy's.+class CorsPolicy m where+  corsPolicy :: Proxy m -> Policy++-- | The 'PermitAll' policy produces the `permitAll` `Policy`.+data PermitAll++instance CorsPolicy PermitAll where+  corsPolicy _ = permitAll++headerSet :: Bool -> Context -> AccessSet -> [HTTP.Header]+headerSet includeMethods ctx access+  | not (originAllowed access) = []+  | otherwise =+      catMaybes+      [ Hs.headerPair Hp.accessControlMaxAge (maxAge access)+      , do guard includeMethods+           Hs.headerPair Hp.accessControlAllowMethods (methodsAllowed access)+      , Hs.headerPair Hp.accessControlAllowOrigin (origin ctx)+      , Hs.headerPair Hp.accessControlExposeHeaders (headersExposed access)+      , Hs.headerPair Hp.accessControlAllowHeaders (headersAllowed access)+      , Hs.headerPair Hp.accessControlAllowCredentials (credentialsAllowed access)+      ]++-- | The 'CorsContext' provides data from which we can make choices about+-- how to respond to CORS requests.+data Context+  = Context+   { origin           :: Text+   , headersExpected  :: Set HTTP.HeaderName+   , headersReturned  :: Set HTTP.HeaderName+   , methodsAvailable :: Set Verb+   }++mergeContext :: Context -> Context -> Context+mergeContext a b =+  Context+  { origin = origin a+  , headersExpected = headersExpected a <> headersExpected b+  , headersReturned = headersReturned a <> headersReturned b+  , methodsAvailable = methodsAvailable a <> methodsAvailable b+  }++-- | Descrbes what parts of the response should be made available+-- cross-origin. The Monoid product on 'AccessSet's permits all accesses of+-- either of the constituents.+data AccessSet =+  AccessSet+  { originAllowed      :: Bool+  , headersExposed     :: Set HTTP.HeaderName+  , credentialsAllowed :: Bool+  , methodsAllowed     :: Set Verb+  , headersAllowed     :: Set HTTP.HeaderName+  , maxAge             :: Maybe NominalDiffTime+  }++-- | The empty access set disallows all CORS access while the product @l <>+-- r@ provides access to a particular part of the response if either @l@ or+-- @r@ does.+instance Monoid AccessSet where+  mempty =+    AccessSet+    { originAllowed = False+    , headersExposed = mempty+    , credentialsAllowed = False+    , methodsAllowed = mempty+    , headersAllowed = mempty+    , maxAge = Nothing+    }+  mappend a b =+    AccessSet+    { originAllowed = originAllowed a || originAllowed b+    , headersExposed = headersExposed a <> headersExposed b+    , credentialsAllowed = credentialsAllowed a || credentialsAllowed b+    , methodsAllowed = methodsAllowed a <> methodsAllowed b+    , headersAllowed = headersAllowed a <> headersAllowed b+    , maxAge = liftA2 max (maxAge a) (maxAge b)+    }+++-- | The most permissive CORS 'Policy' possible. Differs from Wildcard in+-- that it allows credentials. Max age is not provided (so no caching)+permitAll :: Policy+permitAll _config ctx =+  AccessSet+  { originAllowed  = True+  , headersExposed = headersReturned ctx+  , headersAllowed = headersExpected ctx+  , credentialsAllowed = True+  , methodsAllowed = methodsAvailable ctx+  , maxAge = Nothing+  }++-- | Effects a wildcard policy which provides maximal cross-origin access+-- to all request origins. This disallows credentials use, however.+wildcard :: Policy+wildcard config ctx =+  (permitAll config ctx)+  { credentialsAllowed = False }++-- | Provides access to all origins which pass a predicate+predicateWhitelist :: (Text -> Bool) -> Policy+predicateWhitelist originOk config ctx =+  (permitAll config ctx)+  { originAllowed = originOk (origin ctx) }

@@ -0,0 +1,64 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++module Serv.Internal.Header (++  HeaderName (..),+  reflectName,+  ReflectName,+  ReflectHeaders (..),+  ReflectHeaderNames (..),+  HeaderEncode (..),+  headerEncodeRaw,+  headerPair,+  HeaderDecode (..),+  headerDecodeRaw++  ) where++import           Data.Proxy+import           Data.Text.Encoding                 (encodeUtf8)+import qualified Network.HTTP.Types                 as HTTP+import           Serv.Internal.Header.Name+import           Serv.Internal.Header.Serialization+import           Serv.Internal.Pair+import           Serv.Internal.Rec++-- | Given a header set description, reflect out all of the names+class ReflectHeaderNames headers where+  reflectHeaderNames :: Proxy headers -> [HTTP.HeaderName]++instance ReflectHeaderNames '[] where+  reflectHeaderNames _ = []++instance+  (ReflectName name, ReflectHeaderNames hdrs) =>+  ReflectHeaderNames (name '::: ty ': hdrs)+  where+    reflectHeaderNames _ =+      reflectName (Proxy :: Proxy name)+      : reflectHeaderNames (Proxy :: Proxy hdrs)++-- | Given a record of headers, encode them into a list of header pairs.+class ReflectHeaders headers where+  reflectHeaders :: Rec headers -> [HTTP.Header]++instance ReflectHeaders '[] where+  reflectHeaders Nil = []++instance+  (ReflectName name, HeaderEncode name ty, ReflectHeaders headers) =>+    ReflectHeaders ( name '::: ty ': headers )+  where+    reflectHeaders (Cons val headers) =+      -- NOTE: Utf8 encoding is somewhat significantly too lax+      case headerEncode proxy val of+        Nothing -> reflectHeaders headers+        Just txt -> (reflectName proxy, encodeUtf8 txt) : reflectHeaders headers+      where+        proxy = Proxy :: Proxy name

@@ -0,0 +1,725 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Serv.Internal.Header.Name where++import           Data.Proxy+import           Data.String+import           GHC.TypeLits+import qualified Network.HTTP.Types as HTTP++-- This is a GHC 8 feature. It won't work today because we+-- cannot promote a GADT the way that we'd like to. Otherwise,+-- we'd let each name specify its "direction".+--+-- For instance, we'd have+--+--     data HeaderName (d :: Direction) where+--       Name :: Symbol -> HeaderName d+--       CacheControl :: HeaderName d+--       Accept :: HeaderName Request+--       Allow :: HeaderName Response+--+-- etc.+--+--     -- | Qualifier of header types.+--     data Direction = Request | Response++-- | The variant (name and meaning) of a HTTP header.+--+-- An incomplete listing of most permanant headers, a selection of provisional+-- ones, and one or two non-standard headers. Generally, any header desired can+-- be specified using the 'Name' constructor.+--+-- Used only as their @DataKinds@ types system.+data HeaderName++  ---- WILDCARD HEADER NAMES++  = HeaderName 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++-- | Implements reflection of 'Name' types into 'HTTP.HeaderName' values for runtime use.+class ReflectName (n :: HeaderName) where+  reflectName :: proxy n -> HTTP.HeaderName+++-- Proxies+-- ----------------------------------------------------------------------------++cacheControl :: Proxy 'CacheControl+cacheControl = Proxy++connection :: Proxy 'Connection+connection = Proxy++contentLength :: Proxy 'ContentLength+contentLength = Proxy++contentType :: Proxy 'ContentType+contentType = Proxy++date :: Proxy 'Date+date = Proxy++pragma :: Proxy 'Pragma+pragma = Proxy++upgrade :: Proxy 'Upgrade+upgrade = Proxy++via :: Proxy 'Via+via = Proxy++warning :: Proxy 'Warning+warning = Proxy++accept :: Proxy 'Accept+accept = Proxy++acceptCharset :: Proxy 'AcceptCharset+acceptCharset = Proxy++acceptEncoding :: Proxy 'AcceptEncoding+acceptEncoding = Proxy++acceptLanguage :: Proxy 'AcceptLanguage+acceptLanguage = Proxy++accessControlRequestMethod :: Proxy 'AccessControlRequestMethod+accessControlRequestMethod = Proxy++accessControlRequestHeaders :: Proxy 'AccessControlRequestHeaders+accessControlRequestHeaders = Proxy++authorization :: Proxy 'Authorization+authorization = Proxy++cookie :: Proxy 'Cookie+cookie = Proxy++expect :: Proxy 'Expect+expect = Proxy++from :: Proxy 'From+from = Proxy++host :: Proxy 'Host+host = Proxy++ifMatch :: Proxy 'IfMatch+ifMatch = Proxy++ifModifiedSince :: Proxy 'IfModifiedSince+ifModifiedSince = Proxy++ifNoneMatch :: Proxy 'IfNoneMatch+ifNoneMatch = Proxy++ifRange :: Proxy 'IfRange+ifRange = Proxy++ifUnmodifiedSince :: Proxy 'IfUnmodifiedSince+ifUnmodifiedSince = Proxy++maxForwards :: Proxy 'MaxForwards+maxForwards = Proxy++origin :: Proxy 'Origin+origin = Proxy++proxyAuthorization :: Proxy 'ProxyAuthorization+proxyAuthorization = Proxy++range :: Proxy 'Range+range = Proxy++referer :: Proxy 'Referer+referer = Proxy++tE :: Proxy 'TE+tE = Proxy++userAgent :: Proxy 'UserAgent+userAgent = Proxy++xForwardedFor :: Proxy 'XForwardedFor+xForwardedFor = Proxy++xForwardedHost :: Proxy 'XForwardedHost+xForwardedHost = Proxy++xForwardedProto :: Proxy 'XForwardedProto+xForwardedProto = Proxy++xCsrfToken :: Proxy 'XCsrfToken+xCsrfToken = Proxy++accessControlAllowOrigin :: Proxy 'AccessControlAllowOrigin+accessControlAllowOrigin = Proxy++accessControlExposeHeaders :: Proxy 'AccessControlExposeHeaders+accessControlExposeHeaders = Proxy++accessControlMaxAge :: Proxy 'AccessControlMaxAge+accessControlMaxAge = Proxy++accessControlAllowCredentials :: Proxy 'AccessControlAllowCredentials+accessControlAllowCredentials = Proxy++accessControlAllowMethods :: Proxy 'AccessControlAllowMethods+accessControlAllowMethods = Proxy++accessControlAllowHeaders :: Proxy 'AccessControlAllowHeaders+accessControlAllowHeaders = Proxy++acceptPatch :: Proxy 'AcceptPatch+acceptPatch = Proxy++acceptRanges :: Proxy 'AcceptRanges+acceptRanges = Proxy++age :: Proxy 'Age+age = Proxy++allow :: Proxy 'Allow+allow = Proxy++contentDisposition :: Proxy 'ContentDisposition+contentDisposition = Proxy++contentEncoding :: Proxy 'ContentEncoding+contentEncoding = Proxy++contentLanguage :: Proxy 'ContentLanguage+contentLanguage = Proxy++contentLocation :: Proxy 'ContentLocation+contentLocation = Proxy++contentRange :: Proxy 'ContentRange+contentRange = Proxy++contentSecurityPolicy :: Proxy 'ContentSecurityPolicy+contentSecurityPolicy = Proxy++eTag :: Proxy 'ETag+eTag = Proxy++expires :: Proxy 'Expires+expires = Proxy++lastModified :: Proxy 'LastModified+lastModified = Proxy++link :: Proxy 'Link+link = Proxy++location :: Proxy 'Location+location = Proxy++proxyAuthenticate :: Proxy 'ProxyAuthenticate+proxyAuthenticate = Proxy++publicKeyPins :: Proxy 'PublicKeyPins+publicKeyPins = Proxy++retryAfter :: Proxy 'RetryAfter+retryAfter = Proxy++setCookie :: Proxy 'SetCookie+setCookie = Proxy++strictTransportSecurity :: Proxy 'StrictTransportSecurity+strictTransportSecurity = Proxy++trailer :: Proxy 'Trailer+trailer = Proxy++transferEncoding :: Proxy 'TransferEncoding+transferEncoding = Proxy++vary :: Proxy 'Vary+vary = Proxy++wWWAuthenticate :: Proxy 'WWWAuthenticate+wWWAuthenticate = Proxy+++-- ReflectName Instances+--+-- A very verbose way of matching on lots of simple types. Not really worth+-- your time reading. Heavy potential for bugs.+-- ----------------------------------------------------------------------------+++instance KnownSymbol s => ReflectName ('HeaderName s) where+  reflectName _ = fromString (symbolVal (Proxy :: Proxy s))++instance ReflectName 'CacheControl where reflectName _ = "Cache-Control"+instance ReflectName 'Connection where reflectName _ = "Connection"+instance ReflectName 'ContentLength where reflectName _ = "Content-Length"+instance ReflectName 'ContentType where reflectName _ = "Content-Type"+instance ReflectName 'Date where reflectName _ = "Date"+instance ReflectName 'Pragma where reflectName _ = "Pragma"+instance ReflectName 'Upgrade where reflectName _ = "Upgrade"+instance ReflectName 'Via where reflectName _ = "Via"+instance ReflectName 'Warning where reflectName _ = "Warning"+instance ReflectName 'Accept where reflectName _ = "Accept"+instance ReflectName 'AcceptCharset where reflectName _ = "Accept-Charset"+instance ReflectName 'AcceptEncoding where reflectName _ = "Accept-Encoding"+instance ReflectName 'AcceptLanguage where reflectName _ = "Accept-Language"+instance ReflectName 'AccessControlRequestMethod where reflectName _ = "Access-Control-Request-Method"+instance ReflectName 'AccessControlRequestHeaders where reflectName _ = "Access-Control-Request-Headers"+instance ReflectName 'Authorization where reflectName _ = "Authorization"+instance ReflectName 'Cookie where reflectName _ = "Cookie"+instance ReflectName 'Expect where reflectName _ = "Expect"+instance ReflectName 'From where reflectName _ = "From"+instance ReflectName 'Host where reflectName _ = "Host"+instance ReflectName 'IfMatch where reflectName _ = "If-Match"+instance ReflectName 'IfModifiedSince where reflectName _ = "If-Modified-Since"+instance ReflectName 'IfNoneMatch where reflectName _ = "If-None-Match"+instance ReflectName 'IfRange where reflectName _ = "If-Range"+instance ReflectName 'IfUnmodifiedSince where reflectName _ = "If-Unmodified-Since"+instance ReflectName 'MaxForwards where reflectName _ = "Max-Forwards"+instance ReflectName 'Origin where reflectName _ = "Origin"+instance ReflectName 'ProxyAuthorization where reflectName _ = "Proxy-Authorization"+instance ReflectName 'Range where reflectName _ = "Range"+instance ReflectName 'Referer where reflectName _ = "Referer"+instance ReflectName 'TE where reflectName _ = "TE"+instance ReflectName 'UserAgent where reflectName _ = "User-Agent"+instance ReflectName 'XForwardedFor where reflectName _ = "X-Forwarded-For"+instance ReflectName 'XForwardedHost where reflectName _ = "X-Forwarded-Host"+instance ReflectName 'XForwardedProto where reflectName _ = "X-Forwarded-Proto"+instance ReflectName 'XCsrfToken where reflectName _ = "X-Csrf-Token"+instance ReflectName 'AccessControlAllowOrigin where reflectName _ = "Access-Control-Allow-Origin"+instance ReflectName 'AccessControlExposeHeaders where reflectName _ = "Access-Control-Expose-Headers"+instance ReflectName 'AccessControlMaxAge where reflectName _ = "Access-Control-Max-Age"+instance ReflectName 'AccessControlAllowCredentials where reflectName _ = "Access-Control-Allow-Credentials"+instance ReflectName 'AccessControlAllowMethods where reflectName _ = "Access-Control-Allow-Methods"+instance ReflectName 'AccessControlAllowHeaders where reflectName _ = "Access-Control-Allow-Headers"+instance ReflectName 'AcceptPatch where reflectName _ = "Accept-Patch"+instance ReflectName 'AcceptRanges where reflectName _ = "Accept-Ranges"+instance ReflectName 'Age where reflectName _ = "Age"+instance ReflectName 'Allow where reflectName _ = "Allow"+instance ReflectName 'ContentDisposition where reflectName _ = "Content-Disposition"+instance ReflectName 'ContentEncoding where reflectName _ = "Content-Encoding"+instance ReflectName 'ContentLanguage where reflectName _ = "Content-Language"+instance ReflectName 'ContentLocation where reflectName _ = "Content-Location"+instance ReflectName 'ContentRange where reflectName _ = "Content-Range"+instance ReflectName 'ContentSecurityPolicy where reflectName _ = "Content-Security-Policy"+instance ReflectName 'ETag where reflectName _ = "ETag"+instance ReflectName 'Expires where reflectName _ = "Expires"+instance ReflectName 'LastModified where reflectName _ = "Last-Modified"+instance ReflectName 'Link where reflectName _ = "Link"+instance ReflectName 'Location where reflectName _ = "Location"+instance ReflectName 'ProxyAuthenticate where reflectName _ = "Proxy-Authenticate"+instance ReflectName 'PublicKeyPins where reflectName _ = "Public-Key-Pins"+instance ReflectName 'RetryAfter where reflectName _ = "Retry-After"+instance ReflectName 'SetCookie where reflectName _ = "Set-Cookie"+instance ReflectName 'StrictTransportSecurity where reflectName _ = "Strict-Transport-Security"+instance ReflectName 'Trailer where reflectName _ = "Trailer"+instance ReflectName 'TransferEncoding where reflectName _ = "Transfer-Encoding"+instance ReflectName 'Vary where reflectName _ = "Vary"+instance ReflectName 'WWWAuthenticate where reflectName _ = "WWW-Authenticate"

@@ -0,0 +1,130 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TupleSections         #-}++module Serv.Internal.Header.Serialization where++import qualified Data.ByteString           as S+import qualified Data.CaseInsensitive      as CI+import           Data.Proxy+import           Data.Set                  (Set)+import qualified Data.Set                  as Set+import           Data.Text                 (Text)+import qualified Data.Text                 as Text+import qualified Data.Text.Encoding        as Text+import           Data.Time+import           Network.HTTP.Media        (MediaType, Quality, parseQuality)+import qualified Network.HTTP.Types        as HTTP+import           Serv.Internal.Header.Name+import           Serv.Internal.RawText+import           Serv.Internal.Verb++-- | Represents mechanisms to interpret data types as header-compatible values.+--+-- An instance of @Encode n t@ captures a mechanism for treating values of type+-- @t@ as valid data to substantiate the header @n@.+--+-- Note: While this class allows the encoding of any value into a full Unicode+-- Text value, Headers do not generally accept most Unicode code points. Be+-- conservative in implementing this class.+class ReflectName n => HeaderEncode (n :: HeaderName) a where+  headerEncode :: Proxy n -> a -> Maybe Text++-- | Handles encoding a header all the way to /raw/ bytes.+headerEncodeRaw :: HeaderEncode n a => Proxy n -> a -> Maybe S.ByteString+headerEncodeRaw proxy = fmap Text.encodeUtf8 . headerEncode proxy++instance ReflectName n => HeaderEncode n RawText where+  headerEncode _ (RawText text) = Just text++instance HeaderEncode 'Allow (Set Verb) where+  headerEncode _ verbs =+    Just $ Text.intercalate "," (map (Text.decodeUtf8 . standardName) (Set.toList verbs))++instance HeaderEncode 'Allow [Verb] where+  headerEncode prx verbs = headerEncode prx (Set.fromList verbs)++instance HeaderEncode 'AccessControlExposeHeaders (Set HTTP.HeaderName) where+  headerEncode _ headers =+    Just $ Text.intercalate "," (map (Text.decodeUtf8 . CI.original) (Set.toList headers))++instance HeaderEncode 'AccessControlAllowHeaders (Set HTTP.HeaderName) where+  headerEncode _ headers =+    Just $ Text.intercalate "," (map (Text.decodeUtf8 . CI.original) (Set.toList headers))++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 _ verbs =+    Just $ Text.intercalate "," (map (Text.decodeUtf8 . standardName) (Set.toList verbs))++instance HeaderEncode 'AccessControlAllowMethods [Verb] where+  headerEncode prx verbs = headerEncode prx (Set.fromList verbs)++instance HeaderEncode 'AccessControlAllowCredentials Bool where+  headerEncode _ ok+    | ok = Just "true"+    | otherwise = Just "false"++instance {-# OVERLAPPABLE #-} ReflectName n => HeaderEncode n Bool where+  headerEncode _ ok+    | ok = Just "true"+    | otherwise = Just "false"++instance {-# OVERLAPPABLE #-} ReflectName n => HeaderEncode n Int where+  headerEncode _ i = Just $ Text.pack (show i)++instance {-# OVERLAPPABLE #-} ReflectName n => HeaderEncode n Text where+  headerEncode _ t = Just t++instance {-# OVERLAPPABLE #-} HeaderEncode h t => HeaderEncode h (Maybe t) where+  headerEncode p v = v >>= headerEncode p++-- | Represents mechanisms to interpret data types as header-compatible values.+--+-- An instance of @Decode n t@ captures a mechanism for reading values of type+-- @t@ from header data stored at header @n@.+class ReflectName n => HeaderDecode (n :: HeaderName) a where+  headerDecode :: Proxy n -> Maybe Text -> Either String a++headerDecode' :: HeaderDecode n a => Proxy n -> Text -> Either String a+headerDecode' p = headerDecode p . Just++required :: (Text -> Either String a) -> Maybe Text -> Either String a+required _ Nothing = Left "missing header value"+required f (Just t) = f t++-- | Handles decoding a header all the way from /raw/ bytes.+headerDecodeRaw :: HeaderDecode n a => Proxy n -> Maybe S.ByteString -> Either String a+headerDecodeRaw 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 t++-- | 'RawText' enables capturing the data untouched from the header+instance ReflectName n => HeaderDecode n RawText where+  headerDecode _ = required $ \text -> Right (RawText text)++instance HeaderDecode 'Accept [Quality MediaType] where+  headerDecode _ Nothing = Right []+  headerDecode _ (Just text) =+    case parseQuality (Text.encodeUtf8 text) of+      Nothing -> Left "could not parse media type specification"+      Just qs -> Right qs++instance {-# OVERLAPPABLE #-} HeaderDecode h t => HeaderDecode h (Maybe t) where+  headerDecode _ Nothing = Right Nothing+  headerDecode p (Just t) = fmap Just (headerDecode' p t)++headerPair :: HeaderEncode h v => Proxy h -> v -> Maybe HTTP.Header+headerPair proxy v = fmap (reflectName proxy,) (headerEncodeRaw proxy v)

@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}++module Serv.Internal.MediaType where++import qualified Data.ByteString    as S+import           Data.Proxy+import           Network.HTTP.Media (MediaType)+import qualified Network.HTTP.Media as Media++class HasMediaType ty where+  mediaType :: Proxy ty -> MediaType++class HasMediaType ty => MimeEncode ty val where+  mimeEncode :: Proxy ty -> val -> S.ByteString++class HasMediaType ty => MimeDecode ty val where+  mimeDecode :: Proxy ty -> S.ByteString -> Either String val+++negotiateContent+  :: ReflectEncoders ctypes a =>+     Proxy ctypes -> [Media.Quality MediaType] -> a -> Maybe (MediaType, S.ByteString)+negotiateContent proxy acceptable value =+  fmap+  (\(mt, encoder) -> (mt, encoder value))+  (Media.mapQuality (map (\(mt, enc) -> (mt, (mt, enc))) $ reflectEncoders proxy) acceptable)++-- | Similar to 'negotiateContent' but will always attempt to provide+-- the first content type the server offers if nothing is acceptable.+-- Still fails when no content types are offered (what's going on?)+negotiateContentAlways+  :: ReflectEncoders ctypes a =>+     Proxy ctypes -> [Media.Quality MediaType] -> a -> Maybe (MediaType, S.ByteString)+negotiateContentAlways proxy acceptable value =+  case negotiateContent proxy acceptable value of+    Nothing -> case reflectEncoders proxy of+      [] -> Nothing+      ((mt, encoder) : _) -> Just (mt, encoder value)+    Just result -> Just result++class ReflectEncoders cts ty where+  reflectEncoders :: Proxy cts -> [(MediaType, ty -> S.ByteString)]++instance ReflectEncoders '[] ty where+  reflectEncoders Proxy = []++instance+  (ReflectEncoders cts ty, MimeEncode ct ty) =>+    ReflectEncoders (ct ': cts) ty+  where+    reflectEncoders Proxy =+      (mediaType pCt, mimeEncode pCt) : reflectEncoders pCts+      where+        pCt = Proxy :: Proxy ct+        pCts = Proxy :: Proxy cts+++tryDecode+  :: ReflectDecoders ctypes a =>+     Proxy ctypes -> S.ByteString -> S.ByteString -> Maybe (Either String a)+tryDecode proxy mt body =+  fmap+  (\decoder -> decoder body)+  (Media.mapContentMedia (reflectDecoders proxy) mt)++class ReflectDecoders cts ty where+  reflectDecoders :: Proxy cts -> [(MediaType, S.ByteString -> Either String ty)]++instance ReflectDecoders '[] ty where+  reflectDecoders Proxy = []++instance+  (MimeDecode ct ty, ReflectDecoders cts ty) =>+    ReflectDecoders (ct ': cts) ty+  where+    reflectDecoders Proxy =+      (mediaType pCt, mimeDecode pCt) : reflectDecoders pCts+      where+        pCt = Proxy :: Proxy ct+        pCts = Proxy :: Proxy cts

@@ -0,0 +1,11 @@+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE PolyKinds     #-}+{-# LANGUAGE TypeOperators #-}++module Serv.Internal.Pair where++-- | Equivalent to a tuple at both the type and kind levels,+-- but has a nicer syntax!+data Pair a b = a ::: b++infixr 6 :::

@@ -0,0 +1,50 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}++module Serv.Internal.Query where++import           Data.Proxy+import           Data.String+import           Data.Text             (Text)+import           Data.Text.Encoding    (encodeUtf8)+import           GHC.TypeLits+import qualified Network.HTTP.Types    as HTTP+import           Serv.Internal.Pair+import           Serv.Internal.RawText+import           Serv.Internal.Rec++class QueryEncode (s :: Symbol) a where+  queryEncode :: Proxy s -> a -> Maybe Text++class QueryDecode (s :: Symbol) a where+  queryDecode :: Proxy s -> Maybe Text -> Either String a++instance QueryEncode s RawText where+  queryEncode _ (RawText t) = Just t++instance QueryDecode s RawText where+  queryDecode _ Nothing = Left "expected query value"+  queryDecode _ (Just t) = Right (RawText t)++-- | Given a record of headers, encode them into a list of header pairs.+class ReflectQuery query where+  reflectQuery :: Rec query -> HTTP.Query++instance ReflectQuery '[] where+  reflectQuery Nil = []++instance+  (KnownSymbol s, QueryEncode s a, ReflectQuery query) =>+    ReflectQuery ( s '::: a ': query )+  where+    reflectQuery (Cons val rest) = (name, value) : reflectQuery rest+      where+        proxy = Proxy :: Proxy s+        name = fromString (symbolVal proxy)+        value = encodeUtf8 <$> queryEncode proxy val

@@ -0,0 +1,16 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Serv.Internal.RawText where++import           Data.String+import           Data.Text   (Text)++-- | RawText extracts as, like the name suggests,+-- raw text from URI segments and header values.+--+-- It exists as a default value for extensibility of typeclasses like+-- HeaderDecode and HeaderEncode++newtype RawText =+  RawText { getRawText :: Text }+  deriving (Eq, Ord, Read, Show, Monoid, IsString)

@@ -0,0 +1,52 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++module Serv.Internal.Rec where++import           Data.Proxy+import           Data.Tagged+import           Serv.Internal.Pair++-- | An HList collecting heterogenous types matched up to labeling information+data Rec rs where+  Nil :: Rec '[]+  Cons :: ty -> Rec rs -> Rec ( name '::: ty ': rs )++-- | Append a new header value on to a record+(-:) :: Proxy name -> ty -> Rec rs -> Rec (name '::: ty ': rs)+(-:) _ = Cons++class Elem name e es where+  eGet :: Rec es -> Tagged name e+  eMap :: Tagged name (e -> e) -> Rec es -> Rec es++instance {-# OVERLAPPING #-} Elem name e (name '::: e ': rs) where+  eGet (Cons x _) = Tagged x+  eMap (Tagged f) (Cons x rs) = Cons (f x) rs++instance {-# OVERLAPPABLE #-} Elem name e rs => Elem name e (r ': rs) where+  eGet (Cons _ rs) = eGet rs+  eMap f (Cons x rs) = Cons x (eMap f rs)++class Subset rs qs where+  project :: Rec qs -> Rec rs++instance Subset '[] qs where+  project _ = Nil++instance (Elem name r qs, Subset rs qs) => Subset (name '::: r ': rs) qs where+  project r =+    let Tagged v = (eGet r :: Tagged name r)+    in Cons v (project r)++class RecordIso rs qs where+  reorder :: Rec rs -> Rec qs++instance (Subset rs qs, Subset qs rs) => RecordIso rs qs where+  reorder = project

@@ -0,0 +1,319 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf            #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++module Serv.Internal.Server where++import           Data.Function                ((&))+import           Data.Maybe+import           Data.Proxy+import           Data.Set                     (Set)+import qualified Data.Set                     as Set+import           Data.String+import           Data.Tagged+import           Data.Text                    (Text)+import           GHC.TypeLits+import qualified Network.HTTP.Types           as HTTP+import qualified Network.Wai                  as Wai+import qualified Serv.Header.Proxies          as Hp+import           Serv.Internal.Api+import           Serv.Internal.Api.Analysis+import qualified Serv.Internal.Cors           as Cors+import qualified Serv.Internal.Header         as Header+import           Serv.Internal.Pair+import           Serv.Internal.Rec+import           Serv.Internal.Server.Context (Context)+import qualified Serv.Internal.Server.Context as Context+import qualified Serv.Internal.Server.Error   as Error+import           Serv.Internal.Server.Type+import qualified Serv.Internal.URI            as URI+import qualified Serv.Internal.Verb           as Verb++-- Handling+-- ----------------------------------------------------------------------------++-- | The the core type function responsible for interpreting an 'Api' into a+-- functioning 'Server'. It defines a function 'handle' defined over all forms+-- of 'Api' types which consumes a parallel type defined by the associated+-- type family 'Impl'. If @api :: Api@ then @Impl api m@ is an "implementation"+-- of the 'Api''s server logic executing in the @m@ monad. Then, applying+-- 'handle' to a value of @'Impl' api@ results in a 'Server' which can be+-- executed as a 'Wai.Application'.++class Handling (spec :: k) where+  type Impl spec (m :: * -> *)+  handle :: Monad m => Proxy spec -> Impl spec m -> Server m++{-++TODO+----++- [X] 'Method verb headers body+- [T] 'CaptureHeaders headers api+- [T] 'CaptureQuery query api+- [T] 'CaptureBody ctypes value api+- [X] 'Raw++- [X] '[]+- [X] x ': xs++- [X] OneOf apis+- [X] Endpoint apis++- [X] Const s :> api+- [X] HeaderAs name value :> api+- [X] Seg name value :> api+- [X] Header name value :> api+- [X] Wildcard :> api+- [ ] Flag name :> api+- [ ] QueryParam name value :> api+- [X] Cors :> api++-}++encodeBody :: WaiResponse hdrs body => Context -> Response hdrs body -> ServerValue+encodeBody ctx resp =+  case acceptHdr of+    Left _ -> WaiResponse (waiResponse [] resp)+    Right acceptList ->+      WaiResponse (waiResponse acceptList resp)+  where+    (_, acceptHdr) = Context.examineHeader Hp.accept ctx++-- | 'GET' is special-cased to handle @HEAD@ semantics which cannot be+-- specified otherwise.+instance+  {-# OVERLAPPING  #-}+  WaiResponse headers body =>+  Handling ('Method 'Verb.GET headers body) where++  type Impl ('Method 'Verb.GET headers body) m =+    m (Response headers body)++  handle _ mresp = Server $ \ctx -> do+    let method = Context.method ctx+    case method of+      "GET" -> do+        resp <- mresp+        return (encodeBody ctx resp)+      "HEAD" -> do+        resp <- mresp+        let newResp = deleteBody resp+        return (WaiResponse (waiResponse [] newResp))+      _ -> routingError Error.NotFound++instance+  (Verb.ReflectVerb verb, WaiResponse headers body) =>+  Handling ('Method verb headers body) where++  type Impl ('Method verb headers body) m =+    m (Response headers body)++  handle _ mresp = Server $ \ctx -> do+    let method = Context.method ctx+        expected = Verb.reflectVerb (Proxy :: Proxy verb)+    if method /= Verb.standardName expected+       then routingError Error.NotFound+       else do+         resp <- mresp+         case snd (Context.examineHeader Hp.accept ctx) of+           Left _err ->+             routingError+             (Error.BadRequest+              (Just "could not parse acceptable content types"))+           Right accepts ->+             return (WaiResponse $ waiResponse accepts resp)++instance Handling method =>+  Handling ('CaptureHeaders (headers :: [Pair Header.HeaderName *]) method) where+  type Impl ('CaptureHeaders headers method) m =+    Rec headers -> Impl method m+  handle = undefined -- TODO++instance Handling method =>+  Handling ('CaptureQuery (query :: [Pair Symbol *]) method) where+  type Impl ('CaptureQuery query method) m =+    Rec query -> Impl method m+  handle = undefined -- TODO++instance Handling method =>+  Handling ('CaptureBody ctypes (value :: *) method) where+  type Impl ('CaptureBody ctypes value method) m =+    value -> Impl method m+  handle = undefined -- TODO++instance Handling 'Raw where+  type Impl 'Raw m = m Wai.Application+  handle _ impl = Server $ \_ -> do+    app <- impl+    return (Application app)++instance+  (VerbsOf methods,+   HeadersReturnedBy methods,+   HeadersExpectedOf methods,+   Handling methods)+  => Handling ('Endpoint (methods :: [Method *]))+  where+    type Impl ('Endpoint methods) m = Impl methods m+    handle Proxy impl = Server $ \ctx -> do+      let pathIsEmpty = Context.pathIsEmpty ctx+      if not pathIsEmpty+        then routingError Error.NotFound+        else do+          let method = Context.method ctx+              methodsProxy = Proxy :: Proxy methods+          if | method == HTTP.methodOptions ->+                 return $ defaultOptionsResponse verbs+                        & addHeaders (+                            fromMaybe [] $ Context.corsHeaders methodsProxy True ctx+                          )++             | verbMatch verbs method -> do+                 value <- runServer (handle (Proxy :: Proxy methods) impl) ctx+                 return $ value+                        & addHeaders (+                            fromMaybe [] $ Context.corsHeaders methodsProxy False ctx+                          )++             | otherwise ->+               -- TODO: Probably a double-check; trying the method implementations+               -- ought to fail this way, too+               routingError (Error.MethodNotAllowed (Set.toList verbs))+      where+        verbs = verbsOf (Proxy :: Proxy methods)+        addHeaders hdrs v =+          case v of+            WaiResponse resp ->+              WaiResponse (Wai.mapResponseHeaders (hdrs ++) resp)+            other -> other+++-- | Is the request method in the set of verbs?+verbMatch :: Set Verb.Verb -> HTTP.Method -> Bool+verbMatch verbs methodname =+    case methodname of+      -- Special-casing the GET/HEAD overlap+      "HEAD" -> verbMatch verbs "GET"+      _ -> methodname `Set.member` Set.map Verb.standardName verbs++defaultOptionsResponse :: Set Verb.Verb -> ServerValue+defaultOptionsResponse verbs =+  -- TODO: Add CORS information+  WaiResponse+  $ Wai.responseLBS+    HTTP.ok200+    (catMaybes [Header.headerPair Hp.allow orderedVerbs])+    ""+  where+    allVerbs =+      if Set.member Verb.GET verbs+        then verbs & Set.insert Verb.HEAD+                   & Set.insert Verb.OPTIONS+        else verbs & Set.insert Verb.OPTIONS+    orderedVerbs = Set.toList allVerbs++instance Handling '[] where+  type Impl '[] m = m NotHere+  handle _ m = Server $ \_ -> do+    NotHere <- m+    routingError Error.NotFound++instance (Handling x, Handling xs) => Handling (x ': xs) where+  type Impl (x ': xs) m = Impl x m :<|> Impl xs m+  handle _ (l :<|> r) = lServer `orElse` rServer where+    lServer = handle (Proxy :: Proxy x) l+    rServer = handle (Proxy :: Proxy xs) r++instance Handling apis => Handling ('OneOf apis) where+  type Impl ('OneOf apis) m = Impl apis m+  handle _ = handle (Proxy :: Proxy apis)++instance (KnownSymbol s, Handling api) => Handling ('Const s ':> api) where+  type Impl ('Const s ':> api) m = Impl api m+  handle _ impl = Server $ \ctx -> do+    let (ctx', m) = Context.takeSegment ctx+        matchName = fromString (symbolVal (Proxy :: Proxy s))+        next = handle (Proxy :: Proxy api) impl+    case m of+      Nothing -> routingError Error.NotFound+      Just seg+        | seg /= matchName -> routingError Error.NotFound+        | otherwise -> runServer next ctx'++instance Handling api => Handling ('Wildcard ':> api) where+  type Impl ('Wildcard ':> api) m = [Text] -> Impl api m+  handle _ f = Server $ \ctx -> do+    let (ctx', segs) = Context.takeAllSegments ctx+    runServer (handle (Proxy :: Proxy api) (f segs)) ctx'++instance (Header.ReflectName n, KnownSymbol v, Handling api) => Handling ('HeaderAs n v ':> api) where+  type Impl ('HeaderAs s v ':> api) m = Impl api m+  handle _ impl = Server $ \ctx -> do+    let headerProxy = Proxy :: Proxy n+        headerValue = fromString (symbolVal (Proxy :: Proxy v))+        next = handle (Proxy :: Proxy api) impl+        (ctx', ok) = Context.expectHeader headerProxy headerValue ctx+    if ok+      then runServer next ctx'+      else routingError Error.NotFound++instance+  (Header.HeaderDecode n v, Handling api) => Handling ('Header n v ':> api)+  where+    type Impl ('Header n v ':> api) m = v -> Impl api m+    handle _ impl = Server $ \ctx -> do+      let headerProxy = Proxy :: Proxy n+          (ctx', m) = Context.examineHeader headerProxy ctx+          next = handle (Proxy :: Proxy api) . impl+      case m of+        Left parseError -> routingError (Error.BadRequest (Just parseError))+        Right value -> runServer (next value) ctx'++instance (URI.URIDecode v, Handling api) => Handling ('Seg n v ':> api) where+  type Impl ('Seg n v ':> api) m = Tagged n v -> Impl api m+  handle _ impl = Server $ \ctx -> do+    let (ctx', m) = Context.takeSegment ctx+        next = handle (Proxy :: Proxy api) . impl+    case m of+      Nothing -> routingError Error.NotFound+      Just seg -> case URI.uriDecode seg of+        Left _err -> routingError (Error.BadRequest Nothing)+        Right val -> runServer (next $ Tagged val) ctx'++instance (Handling api, Cors.CorsPolicy p) => Handling ('Cors p ':> api) where+  type Impl ('Cors p ':> api) m = Impl api m+  handle _ impl = Server $ \ctx ->+    let newCtx = ctx { Context.corsPolicies =+                         Cors.corsPolicy (Proxy :: Proxy p)+                         : Context.corsPolicies ctx }+    in runServer (handle (Proxy :: Proxy api) impl) newCtx++-- instance (ContentMatching cts ty, Handling api) => Handling ('CaptureBody cts ty ':> api) where++--   type Impl ('CaptureBody cts ty ':> api) m =+--     ty -> Impl api m++--   handle Proxy impl = Server $ do+--     (newContext, maybeHeader) <- asks $ Context.pullHeaderRaw HTTP.hContentType+--     let header = fromMaybe "application/octet-stream" maybeHeader+--     reqBody <- asks Context.body+--     case Media.mapContentMedia matches header of+--       Nothing -> throwError Error.UnsupportedMediaType+--       Just decoder -> case decoder reqBody of+--         Left err -> throwError $ Error.BadRequest (Just err)+--         Right val -> local (const newContext) (continue val)++--     where+--       matches = contentMatch (Proxy :: Proxy cts)+--       continue = runServer . handle (Proxy :: Proxy api) . impl

@@ -0,0 +1,8 @@++module Serv.Internal.Server.Config where++data Config =+  Config++defaultConfig :: Config+defaultConfig = Config

@@ -0,0 +1,178 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++module Serv.Internal.Server.Context where++import qualified Data.ByteString             as S+import qualified Data.ByteString.Lazy        as Sl+import qualified Data.IORef                  as IORef+import           Data.Monoid+import           Data.Proxy+import           Data.Set                    (Set)+import qualified Data.Set                    as Set+import           Data.Text                   (Text)+import qualified Network.HTTP.Types          as HTTP+import qualified Network.Wai                 as Wai+import qualified Serv.Header.Proxies         as Hp+import qualified Serv.Internal.Api.Analysis  as Analysis+import qualified Serv.Internal.Cors          as Cors+import qualified Serv.Internal.Header        as Header+import           Serv.Internal.RawText+import           Serv.Internal.Server.Config+import qualified Serv.Internal.URI           as URI++data Context =+  Context+  { request         :: Wai.Request+  , pathZipper      :: ([Text], [Text])+  , headersExpected :: [(HTTP.HeaderName, Maybe Text)]+  , config          :: Config++    -- cached via strictRequestBody so that we don't have to deal with multiple+    -- request body pulls affecting one another; this defeats partial and lazy body+    -- loading, BUT the style of API description we're talking about here isn't really+    -- amenable to that sort of thing anyway.+    --+    -- also note that we really need to compute this using Lazy IO; otherwise,+    -- we'll have to be handling the partial request/respond dance from the get-go.++  , body            :: S.ByteString++  , corsPolicies :: [Cors.Policy]+  }++corsHeaders+  :: (Analysis.HeadersExpectedOf methods,+     Analysis.HeadersReturnedBy methods,+     Analysis.VerbsOf methods)+  => Proxy methods -> Bool -> Context -> Maybe [HTTP.Header]+corsHeaders proxy includeMethods ctx = do+  let derivedExpected = Analysis.headersExpectedOf proxy+      derivedReturned = Analysis.headersReturnedBy proxy+      derivedVerbs = Analysis.verbsOf proxy+      policyChain = corsPolicies ctx+      conf = config ctx+  RawText origin <- examineHeaderFast Hp.origin ctx+  let corsContext =+        Cors.Context+        { Cors.origin = origin+        , Cors.headersExpected =+            Set.fromList (map fst (headersExpected ctx))+            <> derivedExpected+        , Cors.headersReturned = derivedReturned+        , Cors.methodsAvailable = derivedVerbs+        }+  let accessSet = foldMap (\p -> p conf corsContext) policyChain+  return (Cors.headerSet includeMethods corsContext accessSet)++makeContext :: Config -> Wai.Request -> IO Context+makeContext theConfig theRequest = do+  theBody <- Wai.strictRequestBody theRequest+  -- We create a "frozen", strict version of the body and augment the request to+  -- always return it directly.+  ref <- IORef.newIORef (Sl.toStrict theBody)+  return Context { request = theRequest { Wai.requestBody = IORef.readIORef ref }+                 , config = theConfig+                 , body = Sl.toStrict theBody+                 , pathZipper = ([], Wai.pathInfo theRequest)+                 , headersExpected = []+                 , corsPolicies = []+                 }++pathIsEmpty :: Context -> Bool+pathIsEmpty ctx = case pathZipper ctx of+  (_, []) -> True+  _ -> False++method :: Context -> HTTP.Method+method = Wai.requestMethod . request++requestHeadersSeen :: Context -> Set HTTP.HeaderName+requestHeadersSeen = Set.fromList . map fst . headersExpected++-- | Pop all remaining segments off the context+takeAllSegments :: Context -> (Context, [Text])+takeAllSegments ctx = (newContext, fore) where+  newContext = ctx { pathZipper = (reverse fore ++ hind, []) }+  (hind, fore) = pathZipper ctx++-- | Pop a segment off the URI and produce a new context for "beyond" that segment+takeSegment :: Context -> (Context, Maybe Text)+takeSegment ctx = (stepContext ctx, safeHead fore) where+  (_, fore) = pathZipper ctx++-- | Move the context down the URI segment listing one step if possible.+stepContext :: Context -> Context+stepContext ctx =+  case fore of+    [] -> ctx+    seg : rest -> ctx { pathZipper = (seg : hind, rest) }++  where+    (hind, fore) = pathZipper ctx++-- | Pull a Header raw from the context, updating it to note that we looked+pullHeaderRaw :: HTTP.HeaderName -> Context -> (Context, Maybe S.ByteString)+pullHeaderRaw name ctx =+  (newContext, lookup name headers)+  where+    newContext = ctx { headersExpected = (name, Nothing) : headersExpected ctx }+    headers = Wai.requestHeaders req+    req = request ctx++-- | Pull a header value from the context, updating it to note that we looked+examineHeader+  :: Header.HeaderDecode n a+     => Proxy n -> Context -> (Context, Either String a)+examineHeader proxy ctx =+  (newContext, Header.headerDecodeRaw proxy rawString)+  where+    headerName = Header.reflectName proxy+    (newContext, rawString) = pullHeaderRaw headerName ctx++-- | Sort of like 'examineHeader' but used for when we just want the value+-- and don't care about updating the context or worrying about+-- distinguishing between decoding failure and outright not being there at+-- all!+examineHeaderFast :: Header.HeaderDecode n a => Proxy n -> Context -> Maybe a+examineHeaderFast proxy ctx =+  let (_, hdr) = pullHeaderRaw (Header.reflectName proxy) ctx+  in hush (Header.headerDecodeRaw proxy hdr)+  where+    hush :: Either e a -> Maybe a+    hush (Left _) = Nothing+    hush (Right a) = Just a++-- | Match a header value in the context, updating it to show that we looked+expectHeader :: Header.ReflectName n => Proxy n -> Text -> Context -> (Context, Bool)+expectHeader proxy value ctx =+  (newContext, valOk)++  where+    valOk =+      case fmap URI.fromByteString mayVal of+        Nothing -> False+        Just (Left _) -> False+        Just (Right (RawText observation)) -> observation == value++    headerName = Header.reflectName proxy+    mayVal = lookup headerName headers+    newContext = ctx { headersExpected = (headerName, Just value) : headersExpected ctx }+    headers = Wai.requestHeaders req+    req = request ctx++-- Util+-- ----------------------------------------------------------------------------++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (a : _) = Just a

@@ -0,0 +1,17 @@++module Serv.Internal.Server.Error where++import           Serv.Internal.Verb++-- | Errors which arise during the "handling" portion of dealing with a response.+data RoutingError+  = NotFound+  | BadRequest (Maybe String)+  | UnsupportedMediaType+  | MethodNotAllowed [Verb]++-- | An ignorable error is one which backtracks the routing search+-- instead of forcing a response.+ignorable :: RoutingError -> Bool+ignorable NotFound = True+ignorable _ = False

@@ -0,0 +1,221 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}++module Serv.Internal.Server.Type where++import Data.String+import Data.Maybe (fromMaybe)+import qualified Data.ByteString.Char8         as S8+import qualified Data.ByteString.Lazy         as Sl+import           Data.Function                ((&))+import           Data.Proxy+import           Network.HTTP.Media           (MediaType, Quality, renderHeader)+import qualified Network.HTTP.Types           as HTTP+import qualified Network.Wai                  as Wai+import           Serv.Internal.Api+import qualified Serv.Internal.Header         as Header+import qualified Serv.Internal.MediaType      as MediaType+import           Serv.Internal.Pair+import           Serv.Internal.Rec+import qualified Serv.Internal.Verb as Verb+import           Serv.Internal.Server.Context (Context)+import qualified Serv.Internal.Server.Context as Context+import           Serv.Internal.Server.Error   (RoutingError)+import qualified Serv.Internal.Server.Error   as Error++-- | A server implementation which always results in a "Not Found" error. Used to+-- give semantics to "pathological" servers like @'OneOf '[]@ and @Endpoint '[]@.+--+-- These servers could be statically disallowed but (1) they have a semantic+-- sense as described by this type exactly and (2) to do so would require the+-- creation and management of either larger types or non-empty proofs which would+-- be burdensome to carry about.+data NotHere = NotHere++-- | Actual servers are implemented effectfully; this is a no-op server which+-- immediately returns Not Found and applies no effects.+noOp :: Applicative m => m NotHere+noOp = pure NotHere++-- | Either one thing or the other. In particular, often this is used when we are+-- describing either one server implementation or the other. Used to give+-- semantics to @'OneOf@ and @'Endpoint@.+data a :<|> b = a :<|> b++infixr 5 :<|>++-- | A return value from a 'Server' computation.+data ServerValue+  = RoutingError RoutingError+    -- ^ Routing errors arise when a routing attempt fails and, depending on the+    -- error, either we should recover and backtrack or resolve the entire response+    -- with that error.+  | WaiResponse Wai.Response+    -- ^ If the response is arising from the 'Server' computation itself it will+    -- be transformed automatically into a 'Wai.Response' value we can handle+    -- directly. These are opaque to routing, assumed successes.+  | Application Wai.Application+    -- ^ If the application demands an "upgrade" or ties into another server+    -- mechanism then routing at that location will return the (opaque)+    -- 'Application' to continue handling.++runServerWai+  :: Context+  -> (Wai.Response -> IO Wai.ResponseReceived)+  -> (Server IO -> IO Wai.ResponseReceived)+runServerWai context respond server = do+  val <- runServer server context+  case val of+    RoutingError err -> respond $ case err of+      Error.NotFound ->+        Wai.responseLBS HTTP.notFound404 [] ""+      Error.BadRequest e -> do+        let errString = fromString (fromMaybe "" e)+        Wai.responseLBS HTTP.badRequest400 [] (fromString errString)+      Error.UnsupportedMediaType ->+        Wai.responseLBS HTTP.unsupportedMediaType415 [] ""+      Error.MethodNotAllowed verbs -> do+        let verbNames = map Verb.standardName verbs+            allowHeader = S8.intercalate "," verbNames+        Wai.responseLBS HTTP.methodNotAllowed405 [("Allow", allowHeader)] ""++    WaiResponse resp -> respond resp++    -- We forward the request (frozen) and the respond handler+    -- on to the internal application+    Application app -> app (Context.request context) respond++-- A server executing in a given monad. We construct these from 'Api'+-- descriptions and corresponding 'Impl' descriptions for said 'Api's.+-- Ultimately, a 'Server', or at least a 'Server IO', is destined to be+-- transformed into a Wai 'Wai.Appliation', but 'Server' tracks around more+-- information useful for interpretation and route finding.+newtype Server m = Server { runServer :: Context -> m ServerValue }++-- Lift an effect transformation on to a Server+transformServer :: (forall x . m x -> n x) -> Server m -> Server n+transformServer phi (Server act) = Server (phi . act)++-- | 'Server's form a semigroup trying each 'Server' in order and receiving+-- the leftmost one which does not end in an ignorable error.+--+-- Or, with less technical jargon, @m `orElse` n@ acts like @m@ except in the+-- case where @m@ returns an 'Error.ignorable' 'Error.Error' in which case control+-- flows on to @n@.+orElse :: Monad m => Server m -> Server m -> Server m+orElse sa sb = Server $ \ctx -> do+  a <- runServer sa ctx+  case a of+    RoutingError e+      | Error.ignorable e -> runServer sb ctx+      | otherwise -> return a+    _ -> return a++routingError :: Monad m => RoutingError -> m ServerValue+routingError err = return (RoutingError err)++-- Responses+-- ----------------------------------------------------------------------------++-- | Responses generated in 'Server' implementations.+data Response (headers :: [Pair Header.HeaderName *]) body where+  Response+    :: HTTP.Status+    -> [HTTP.Header]+    -> Rec headers+    -> a+    -> Response headers ('Body ctypes a)+  EmptyResponse+    :: HTTP.Status+    -> [HTTP.Header]+    -> Rec headers+    -> Response headers 'Empty++-- An 'emptyResponse' returns the provided status message with no body or headers+emptyResponse :: HTTP.Status -> Response '[] 'Empty+emptyResponse status = EmptyResponse status [] Nil++-- | Adds a body to a response+withBody+  :: a -> Response headers 'Empty -> Response headers ('Body ctypes a)+withBody a (EmptyResponse status secretHeaders headers) =+  Response status secretHeaders headers a++-- | Adds a header to a response+withHeader+  :: Proxy name -> value+  -> Response headers body -> Response (name '::: value ': headers) body+withHeader proxy val r = case r of+  Response status secretHeaders headers body ->+    Response status secretHeaders (headers & proxy -: val) body+  EmptyResponse status secretHeaders headers ->+    EmptyResponse status secretHeaders (headers & proxy -: val)++-- | Unlike 'withHeader', 'withQuietHeader' allows you to add headers+-- not explicitly specified in the api specification.+withQuietHeader+  :: Header.HeaderEncode name value+     => Proxy name -> value+     -> Response headers body -> Response headers body+withQuietHeader proxy value r =+  case Header.headerPair proxy value of+    Nothing -> r+    Just newHeader ->+      case r of+        Response status secretHeaders headers body ->+          Response status (newHeader : secretHeaders) headers body+        EmptyResponse status secretHeaders headers ->+          EmptyResponse status (newHeader : secretHeaders) headers++-- | If a response type is complete defined by its implementation then+-- applying 'resorted' to it will future proof it against reorderings+-- of headers. If the response type is not completely inferrable, however,+-- then this will require manual annotations of the "pre-sorted" response.+resortHeaders :: RecordIso headers headers' => Response headers body -> Response headers' body+resortHeaders r =+  case r of+    Response status secretHeaders headers body ->+      Response status secretHeaders (reorder headers) body+    EmptyResponse status secretHeaders headers ->+      EmptyResponse status secretHeaders (reorder headers)++-- | Used primarily for implementing @HEAD@ request automatically.+deleteBody :: Response headers body -> Response headers 'Empty+deleteBody r =+  case r of+    Response status secretHeaders headers _ ->+      EmptyResponse status secretHeaders headers+    EmptyResponse{} -> r++-- Reflection+-- ----------------------------------------------------------------------------++-- TODO: This is quite weird. It'd be better to have ReflectHeaders show up+-- in fewer places++class Header.ReflectHeaders headers => WaiResponse headers body where+  waiResponse :: [Quality MediaType] -> Response headers body -> Wai.Response++instance Header.ReflectHeaders headers => WaiResponse headers 'Empty where+  waiResponse _ (EmptyResponse status secretHeaders headers) =+    Wai.responseLBS status (secretHeaders ++ Header.reflectHeaders headers) ""++instance+  (Header.ReflectHeaders headers, MediaType.ReflectEncoders ctypes a) =>+    WaiResponse headers ('Body ctypes a)+  where+    waiResponse accepts (Response status secretHeaders headers value) =+      case MediaType.negotiateContentAlways (Proxy :: Proxy ctypes) accepts value of+        Nothing -> Wai.responseLBS HTTP.notAcceptable406 [] ""+        Just (mtChosen, result) ->+          let headers0 = Header.reflectHeaders headers+              headers1 = ("Content-Type", renderHeader mtChosen) : headers0+              headers2 = secretHeaders ++ headers1+          in Wai.responseLBS status headers2 $ Sl.fromStrict result

@@ -0,0 +1,21 @@++module Serv.Internal.URI where++import qualified Data.ByteString.Char8 as S8+import           Data.Text             (Text)+import qualified Data.Text.Encoding    as Enc+import           Serv.Internal.RawText++class URIEncode a where+  uriEncode :: a -> Text++class URIDecode a where+  uriDecode :: Text -> Either String a++instance URIDecode RawText where+  uriDecode text = Right (RawText text)++fromByteString :: URIDecode a => S8.ByteString -> Either String a+fromByteString s = case Enc.decodeUtf8' s of+  Left _err -> Left "could not parse UTF8 string"+  Right a -> uriDecode a

@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}++module Serv.Internal.Verb where++import           Data.Proxy+import qualified Network.HTTP.Types as HTTP++-- TRACE is intentionally omitted because (a) it's very low value and (b)+-- it opens a potential security hole via Cross-Site-Tracing. Instead of+-- even evaluating that risk we'll just disallow it.++data Verb+  = DELETE+  | GET+  | HEAD+  | OPTIONS+  | PATCH+  | POST+  | PUT+    deriving ( Eq, Ord, Show, Read )++standardName :: Verb -> HTTP.Method+standardName v = case v of+  GET -> HTTP.methodGet+  HEAD -> HTTP.methodHead+  POST -> HTTP.methodPost+  PUT -> HTTP.methodPut+  PATCH -> HTTP.methodPatch+  DELETE -> HTTP.methodDelete+  OPTIONS -> HTTP.methodOptions++class ReflectVerb (v :: Verb) where+  reflectVerb :: Proxy v -> Verb++instance ReflectVerb 'GET where reflectVerb Proxy = GET+instance ReflectVerb 'HEAD where reflectVerb Proxy = HEAD+instance ReflectVerb 'POST where reflectVerb Proxy = POST+instance ReflectVerb 'PUT where reflectVerb Proxy = PUT+instance ReflectVerb 'PATCH where reflectVerb Proxy = PATCH+instance ReflectVerb 'DELETE where reflectVerb Proxy = DELETE+instance ReflectVerb 'OPTIONS where reflectVerb Proxy = OPTIONS

@@ -0,0 +1,44 @@++module Serv.Server (++    Server+    , transformServer+    , makeApplication++    , Config+    , defaultConfig++    , Handling (handle)+    , Impl++      -- For implementation+    , (:<|>) (..), NotHere (..)+    , noOp++    , Response+    , emptyResponse+    , withBody+    , withHeader+    , withQuietHeader++      -- HTTP Status re-exports+    , module Network.HTTP.Types.Status+    , module Data.Tagged+++  ) where++import           Data.Tagged+import           Network.HTTP.Types.Status+import qualified Network.Wai                  as Wai+import           Serv.Internal.Server+import           Serv.Internal.Server.Config+import           Serv.Internal.Server.Context+import           Serv.Internal.Server.Type++-- | Build a 'Wai.Application' from an implemented @'Server' 'IO'@.+makeApplication :: Config -> Server IO -> Wai.Application+makeApplication conf server = app where+  app req resp = do+    ctx <- makeContext conf req+    runServerWai ctx resp server

@@ -0,0 +1,9 @@++module Serv.URI (++    URIEncode (..)+  , URIDecode (..)++  ) where++import Serv.Internal.URI

@@ -0,0 +1,111 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++module Examples.Ex1 where++import           Data.Function       ((&))+import           Data.Proxy+import           Data.String+import           Data.Text           (Text)+import qualified Network.Wai         as Wai+import qualified Network.Wai.Test    as T+import qualified Serv.Api            as A+import           Serv.Common+import qualified Serv.ContentType    as Ct+import qualified Serv.Header         as H+import qualified Serv.Header.Proxies as Hp+import           Serv.Server+import           Test.Tasty+import qualified Test.Tasty.HUnit    as Hu++type RawBody = 'A.Body '[ Ct.TextPlain ] Text+type JSONBody = 'A.Body '[ Ct.JSON ] [Int]++type Api+  = 'A.Endpoint+    '[ 'A.Method 'A.GET '[ 'H.CacheControl 'A.::: RawText ] RawBody+     , 'A.Method 'A.PUT '[ 'H.CacheControl 'A.::: RawText ] JSONBody+     ]++apiProxy :: Proxy Api+apiProxy = Proxy++impl :: Impl Api IO+impl = get :<|> put :<|> noOp+  where+    get =+      return+      $ emptyResponse ok200+      & withHeader Hp.cacheControl "foo"+      & withBody "Hello"+    put =+      return+      $ emptyResponse ok200+      & withHeader Hp.cacheControl "foo"+      & withBody [1, 2, 3]+++server :: Server IO+server = handle apiProxy impl++runTest :: T.Session a -> IO a+runTest = flip T.runSession (makeApplication defaultConfig server)++test1 :: TestTree+test1 = testGroup "Simple responses"+  [ Hu.testCase "Constant GET response (RawText)" $ runTest $ do+      let req = Wai.defaultRequest+      resp <- T.request req+      T.assertStatus 200 resp+      T.assertContentType "text/plain" resp+      T.assertBody "Hello" resp+      T.assertHeader "Cache-Control" "foo" resp++  , Hu.testCase "Constant PUT response (JSON)" $ runTest $ do+      let req = Wai.defaultRequest { Wai.requestMethod = "PUT" }+      resp <- T.request req+      T.assertStatus 200 resp+      T.assertContentType "application/json" resp+      T.assertBody "[1,2,3]" resp+      T.assertHeader "Cache-Control" "foo" resp++  , Hu.testCase "Proper OPTIONS response" $ runTest $ do+      let req = Wai.defaultRequest+                { Wai.requestMethod = "OPTIONS" }+      resp <- T.request req+      T.assertStatus 200 resp+      T.assertBody "" resp+      T.assertHeader "Allow" "GET,HEAD,OPTIONS,PUT" resp++  , Hu.testCase "Proper HEAD response" $ runTest $ do+      let req = Wai.defaultRequest+                { Wai.requestMethod = "HEAD" }+      resp <- T.request req+      T.assertStatus 200 resp+      T.assertBody "" resp+      T.assertHeader "Cache-Control" "foo" resp++  , Hu.testCase "Missing response at bad path" $ runTest $ do+      let req =+            Wai.defaultRequest+            & flip T.setPath "/hello"+      resp <- T.request req+      T.assertStatus 404 resp+      T.assertBody "" resp+      T.assertNoHeader "Cache-Control" resp++  , testGroup "Missing responses at wrong methods"+    $ flip map ["DELETE", "POST"] $ \method ->+      Hu.testCase ("Missing response at method " ++ method) $ runTest $ do+        let req =+              Wai.defaultRequest+              { Wai.requestMethod = fromString method }+        resp <- T.request req+        T.assertStatus 405 resp+        T.assertBody "" resp+        T.assertNoHeader "Cache-Control" resp+  ]++tests :: TestTree+tests = testGroup "Example 1" [ test1 ]

@@ -0,0 +1,91 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++-- | Here we test that a CORS response is properly handled. We assume that+-- example.com is an acceptable Origin and that authorization IS allowed.+module Examples.Ex2 where++import           Data.Function       ((&))+import           Data.Proxy+import           Data.Text           (Text)+import qualified Network.Wai         as Wai+import qualified Network.Wai.Test    as T+import qualified Serv.Api            as A+import           Serv.Common+import qualified Serv.ContentType    as Ct+import qualified Serv.Cors           as Cors+import qualified Serv.Header         as H+import qualified Serv.Header.Proxies as Hp+import           Serv.Server+import           Test.Tasty+import qualified Test.Tasty.HUnit    as Hu++type RawBody = 'A.Body '[ Ct.TextPlain ] Text++type Api+  = 'A.Cors Cors.PermitAll 'A.:>+    'A.Header 'H.IfRange (Maybe RawText) 'A.:> 'A.Endpoint+    '[ 'A.Method 'A.GET '[ 'H.XCsrfToken 'A.::: RawText ] RawBody+     , 'A.Method 'A.DELETE '[] 'A.Empty+     ]++apiProxy :: Proxy Api+apiProxy = Proxy++impl :: Impl Api IO+impl _ifRange = get :<|> delete :<|> noOp+  where+    get =+      return+      $ emptyResponse ok200+      & withHeader Hp.xCsrfToken "some-csrf-token"+      & withBody "Hello"+    delete =+      return+      $ emptyResponse noContent204+++server :: Server IO+server = handle apiProxy impl++config :: Config+config =+  defaultConfig++runTest :: T.Session a -> IO a+runTest = flip T.runSession (makeApplication config server)++test1 :: TestTree+test1 = testGroup "Simple responses"+  [ Hu.testCase "CORS successful GET response" $ runTest $ do+      let req = Wai.defaultRequest+                { Wai.requestHeaders = [("Origin", "http://example.com")] }+      resp <- T.request req+      T.assertStatus 200 resp+      T.assertContentType "text/plain" resp+      T.assertBody "Hello" resp+      T.assertHeader "X-Csrf-Token" "some-csrf-token" resp+      T.assertHeader "Access-Control-Allow-Origin" "http://example.com" resp+      T.assertHeader "Access-Control-Expose-Headers" "X-Csrf-Token" resp+      T.assertHeader "Access-Control-Allow-Credentials" "true" resp+      T.assertHeader "Access-Control-Allow-Headers" "If-Range" resp+      T.assertNoHeader "Access-Control-Allow-Methods" resp++  , Hu.testCase "CORS successful OPTIONS pre-flight response" $ runTest $ do+      let req = Wai.defaultRequest+                { Wai.requestHeaders = [("Origin", "http://example.com")]+                , Wai.requestMethod = "OPTIONS"+                }+      resp <- T.request req+      T.assertStatus 200 resp+      T.assertBody "" resp+      T.assertHeader "Access-Control-Allow-Origin" "http://example.com" resp+      T.assertHeader "Access-Control-Allow-Methods" "DELETE,GET,HEAD,OPTIONS" resp+      T.assertHeader "Access-Control-Expose-Headers" "X-Csrf-Token" resp+      T.assertHeader "Access-Control-Allow-Credentials" "true" resp+      T.assertHeader "Access-Control-Allow-Headers" "If-Range" resp+  ]++tests :: TestTree+tests = testGroup "Example 2 -- CORS" [ test1 ]

@@ -0,0 +1,33 @@++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 Examples.Ex1 as Ex1+import qualified Examples.Ex2 as Ex2++main :: IO ()+main =+  defaultMainWithIngredients+  [ antXMLRunner+  , listingTests+  , consoleTestReporter+  ] tests++tests :: TestTree+tests =+  testGroup "Server Tests"+  [ systemTests+  , Ex1.tests+  , Ex2.tests+  ]++systemTests :: TestTree+systemTests = testGroup "System Tests"+  [ Hu.testCase "Trivial tests" trivial+  ] where++trivial :: Assertion+trivial = assertBool "True is False" True