diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Joseph Abrahamson (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/TestServer.hs b/app/TestServer.hs new file mode 100644 --- /dev/null +++ b/app/TestServer.hs @@ -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) diff --git a/serv.cabal b/serv.cabal new file mode 100644 --- /dev/null +++ b/serv.cabal @@ -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 +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 diff --git a/src/Serv/Api.hs b/src/Serv/Api.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Api.hs @@ -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 diff --git a/src/Serv/Common.hs b/src/Serv/Common.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Common.hs @@ -0,0 +1,4 @@ + +module Serv.Common ( RawText (..) ) where + +import Serv.Internal.RawText diff --git a/src/Serv/ContentType.hs b/src/Serv/ContentType.hs new file mode 100644 --- /dev/null +++ b/src/Serv/ContentType.hs @@ -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 diff --git a/src/Serv/Cors.hs b/src/Serv/Cors.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Cors.hs @@ -0,0 +1,17 @@ + +module Serv.Cors ( + + Policy + , Context (..) + , AccessSet (..) + + , CorsPolicy (..) + , PermitAll + + , permitAll + , wildcard + , predicateWhitelist + + ) where + +import Serv.Internal.Cors diff --git a/src/Serv/Header.hs b/src/Serv/Header.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Header.hs @@ -0,0 +1,12 @@ + +module Serv.Header ( + + HeaderName (..) + , HeaderEncode (..) + , HeaderDecode (..) + , ReflectName + + ) where + +import Serv.Internal.Header.Name +import Serv.Internal.Header.Serialization diff --git a/src/Serv/Header/Proxies.hs b/src/Serv/Header/Proxies.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Header/Proxies.hs @@ -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 diff --git a/src/Serv/Internal/Api.hs b/src/Serv/Internal/Api.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Api.hs @@ -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 diff --git a/src/Serv/Internal/Api/Analysis.hs b/src/Serv/Internal/Api/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Api/Analysis.hs @@ -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)) diff --git a/src/Serv/Internal/Cors.hs b/src/Serv/Internal/Cors.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Cors.hs @@ -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) } diff --git a/src/Serv/Internal/Header.hs b/src/Serv/Internal/Header.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Header.hs @@ -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 diff --git a/src/Serv/Internal/Header/Name.hs b/src/Serv/Internal/Header/Name.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Header/Name.hs @@ -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: + + | AccessControlAllowCredentials + -- ^ Indicates whether or not the response to the request can be exposed when the + -- credentials flag is true. When used as part of a response to a preflight request, + -- this indicates whether or not the actual request can be made using credentials. Note + -- that simple GET requests are not preflighted, and so if a request is made for a + -- resource with credentials, if this header is not returned with the resource, the + -- response is ignored by the browser and not returned to web content. + -- + -- Access-Control-Allow-Credentials: true | false + + | AccessControlAllowMethods + -- ^ Specifies the method or methods allowed when accessing the resource. This is + -- used in response to a preflight request. + -- + -- Access-Control-Allow-Methods: [, ]* + + | AccessControlAllowHeaders + -- ^ Used in response to a preflight request to indicate which HTTP headers can + -- be used when making the actual request. + + | AcceptPatch + -- ^ Specifies which patch document formats this server supports + -- + -- Accept-Patch: text/example;charset=utf-8 + + | AcceptRanges + -- ^ What partial content range types this server supports via byte serving + -- + -- Accept-Ranges: bytes + + | Age + -- ^ The age the object has been in a proxy cache in seconds + -- + -- Age: 12 + + | Allow + -- ^ Valid actions for a specified resource. To be used for a 405 Method not allowed + -- + -- Allow: GET, HEAD + + | ContentDisposition + -- ^ An opportunity to raise a "File Download" dialogue box for a known MIME type + -- with binary format or suggest a filename for dynamic content. Quotes are + -- necessary with special characters. + -- + -- Content-Disposition: attachment; filename="fname.ext" + + | ContentEncoding + -- ^ The type of encoding used on the data. + -- + -- Content-Encoding: gzip + + | ContentLanguage + -- ^ The natural language or languages of the intended audience for the enclosed content + -- + -- Content-Language: da + + | ContentLocation + -- ^ An alternate location for the returned data + -- + -- Content-Location: /index.htm + + | ContentRange + -- ^ Where in a full body message this partial message belongs + -- + -- Content-Range: bytes 21010-47021/47022 + + | ContentSecurityPolicy + -- ^ Content Security Policy definition. + -- + -- Content-Security-Policy: default-src 'self' + + | ETag + -- ^ An identifier for a specific version of a resource, often a message digest + -- + -- ETag: "737060cd8c284d8af7ad3082f209582d" + + | Expires + -- ^ Gives the date/time after which the response is considered stale (in + -- "HTTP-date" format as defined by RFC 7231) + -- + -- Expires: Thu, 01 Dec 1994 16:00:00 GMT + + | LastModified + -- ^ The last modified date for the requested object (in "HTTP-date" format as + -- defined by RFC 7231) + -- + -- Last-Modified: Tue, 15 Nov 1994 12:45:26 GMT + + | Link + -- ^ Used to express a typed relationship with another resource, where the + -- relation type is defined by RFC 5988 + -- + -- Link: ; rel="alternate" + + | Location + -- ^ Used in redirection, or when a new resource has been created. + -- + -- Location: http://www.w3.org/pub/WWW/People.html + + | ProxyAuthenticate + -- ^ Request authentication to access the proxy. + -- + -- Proxy-Authenticate: Basic + + | PublicKeyPins + -- ^ HTTP Public Key Pinning, announces hash of website's authentic TLS certificate + -- + -- Public-Key-Pins: max-age=2592000; pin-sha256="E9CZ9INDbd+2eRQozYqqbQ2yXLVKB9+xcprMF+44U1g="; + + | RetryAfter + -- ^ If an entity is temporarily unavailable, this instructs the client to + -- try again later. Value could be a specified period of time (in seconds) or a HTTP-date. + -- + -- Retry-After: 120 + -- Retry-After: Fri, 07 Nov 2014 23:59:59 GMT + + | SetCookie + -- ^ An HTTP cookie + -- + -- Set-Cookie: UserID=JohnDoe; Max-Age=3600; Version=1 + + | StrictTransportSecurity + -- ^ A HSTS Policy informing the HTTP client how long to cache the HTTPS only + -- policy and whether this applies to subdomains. + -- + -- Strict-Transport-Security: max-age=16070400; includeSubDomains + + | Trailer + -- ^ The Trailer general field value indicates that the given set of header fields + -- is present in the trailer of a message encoded with chunked transfer coding. + -- + -- Trailer: Max-Forwards + + | TransferEncoding + -- ^ The form of encoding used to safely transfer the entity to the user. Currently defined + -- methods are: chunked, compress, deflate, gzip, identity. + -- + -- Transfer-Encoding: chunked + + | Vary + -- ^ Tells downstream proxies how to match future request headers to decide whether + -- the cached response can be used rather than requesting a fresh one from the origin server. + -- + -- Vary: * + -- Vary: Accept-Language + + | WWWAuthenticate + -- ^ Indicates the authentication scheme that should be used to access the requested entity. + -- + -- WWW-Authenticate: Basic + +-- | 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" diff --git a/src/Serv/Internal/Header/Serialization.hs b/src/Serv/Internal/Header/Serialization.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Header/Serialization.hs @@ -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) diff --git a/src/Serv/Internal/MediaType.hs b/src/Serv/Internal/MediaType.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/MediaType.hs @@ -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 diff --git a/src/Serv/Internal/Pair.hs b/src/Serv/Internal/Pair.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Pair.hs @@ -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 ::: diff --git a/src/Serv/Internal/Query.hs b/src/Serv/Internal/Query.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Query.hs @@ -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 diff --git a/src/Serv/Internal/RawText.hs b/src/Serv/Internal/RawText.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/RawText.hs @@ -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) diff --git a/src/Serv/Internal/Rec.hs b/src/Serv/Internal/Rec.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Rec.hs @@ -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 diff --git a/src/Serv/Internal/Server.hs b/src/Serv/Internal/Server.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Server.hs @@ -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 diff --git a/src/Serv/Internal/Server/Config.hs b/src/Serv/Internal/Server/Config.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Server/Config.hs @@ -0,0 +1,8 @@ + +module Serv.Internal.Server.Config where + +data Config = + Config + +defaultConfig :: Config +defaultConfig = Config diff --git a/src/Serv/Internal/Server/Context.hs b/src/Serv/Internal/Server/Context.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Server/Context.hs @@ -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 diff --git a/src/Serv/Internal/Server/Error.hs b/src/Serv/Internal/Server/Error.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Server/Error.hs @@ -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 diff --git a/src/Serv/Internal/Server/Type.hs b/src/Serv/Internal/Server/Type.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Server/Type.hs @@ -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 diff --git a/src/Serv/Internal/URI.hs b/src/Serv/Internal/URI.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/URI.hs @@ -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 diff --git a/src/Serv/Internal/Verb.hs b/src/Serv/Internal/Verb.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Internal/Verb.hs @@ -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 diff --git a/src/Serv/Server.hs b/src/Serv/Server.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Server.hs @@ -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 diff --git a/src/Serv/URI.hs b/src/Serv/URI.hs new file mode 100644 --- /dev/null +++ b/src/Serv/URI.hs @@ -0,0 +1,9 @@ + +module Serv.URI ( + + URIEncode (..) + , URIDecode (..) + + ) where + +import Serv.Internal.URI diff --git a/test/Examples/Ex1.hs b/test/Examples/Ex1.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Ex1.hs @@ -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 ] diff --git a/test/Examples/Ex2.hs b/test/Examples/Ex2.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Ex2.hs @@ -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 ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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