diff --git a/app/TestServer.hs b/app/TestServer.hs deleted file mode 100644 --- a/app/TestServer.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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 --- a/serv.cabal +++ b/serv.cabal @@ -1,7 +1,18 @@ name: serv -version: 0.1.0.0 -synopsis: Dependently typed API server framework -description: Please see README.md +version: 0.2.0.0 +synopsis: Dependently typed API framework +description: + Types and kinds for describing APIs. + . + This package defines the kind 'Serv.Api.Api' which classifies types which + statically describe an API. Define your 'Serv.Api.Api'-kinded types and then + write/derive compliant servers, clients, and documentation all statically + guaranteed to match. + . + Import "Serv.Api.Prelude" for the smoothest experience defining these types. + . + See the README for more details. + homepage: http://github.com/tel/serv#readme license: BSD3 license-file: LICENSE @@ -17,81 +28,18 @@ 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 + Serv.Api.Analysis + Serv.Api.Prelude build-depends: base >= 4.7 && < 5 - , aeson - , bytestring - , case-insensitive + , containers - , http-media - , http-types - , mtl - , tagged + , http-kinder + , singletons , 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 + location: https://github.com/tel/serv diff --git a/src/Serv/Api.hs b/src/Serv/Api.hs --- a/src/Serv/Api.hs +++ b/src/Serv/Api.hs @@ -1,15 +1,237 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | Types, but really kinds, which represent the structure of an API. module Serv.Api ( + -- * API types/kinds + Api (..) - , Method (..) - , Body (..) , Path (..) - , Verb (..) - , Pair (..) + , Handler (..) + , Output (..) + , Body (..) - ) where + -- ** Syntax sugar + , type (:::) -import Serv.Internal.Api -import Serv.Internal.Verb -import Serv.Internal.Pair + -- * Singletons + , Sing ( + SEndpoint, SOneOf, SAbstract, (:%>) + , SConst, SHeaderAs, SSeg, SHeader, SWildcard + , SMethod, SCaptureBody, SCaptureHeaders, SCaptureQuery + , SRespond + , SHasBody, SEmpty + ) + + -- * Type aliases + + -- | Eliminates need for single-quoting the @DataKind@-lifted types. + + -- ** 'Api' + , Endpoint, OneOf, Abstract, (:>) + + -- ** 'Path' + , Const, HeaderAs, Seg, Header, Wildcard + + -- ** 'Handler' + , Method, CaptureBody, CaptureHeaders, CaptureQuery + + -- ** 'Output' + , Respond + + -- ** 'Body' + , HasBody, Empty + +) where + +import Data.Singletons +import Data.Singletons.TypeLits +import Network.HTTP.Kinder.Header (HeaderName) +import Network.HTTP.Kinder.Status (Status) +import Network.HTTP.Kinder.Verb + +-- | Extra syntax-sugar for representing type-level pairs. +type a ::: b = '( a, b ) +infixr 6 ::: + +-- | 'Handler' responses may opt to include a response body or not. +data Body star + = HasBody [star] star + -- ^ Return a response body by specifying a set of content-types and + -- a value to derive the body from. + | Empty + -- ^ A response with an empty body + +data instance Sing (b :: Body *) + = forall ts a . b ~ HasBody ts a => SHasBody (Sing ts) (Sing a) + | b ~ Empty => SEmpty + +instance (SingI ts, SingI a) => SingI ('HasBody ts a :: Body *) where + sing = SHasBody sing sing + +instance SingI ('Empty :: Body *) where + sing = SEmpty + +type HasBody ctypes ty = 'HasBody ctypes ty +type Empty = 'Empty + + + +-- | Describes an output from an API under a given status. +data Output star = Respond [ (HeaderName, star) ] (Body star) + +data instance Sing (o :: Output *) + = forall ts b . o ~ Respond ts b => SRespond (Sing ts) (Sing b) + +instance (SingI ts, SingI b) => SingI ('Respond ts b :: Output *) where + sing = SRespond sing sing + +type Respond hdrs body = 'Respond hdrs body + + + + +-- | A 'Handler' is a single HTTP verb response handled at a given 'Endpoint'. +-- In order to complete a 'Handler''s operation it may demand data from the +-- request such as headers or the request body. +data Handler star + = Method Verb [(Status, Output star)] + -- ^ A "core" 'Handler' definition which describes the 'Verb' it + -- responds to along with a set of response headers and a chance to + -- attach a response 'Body'. + | CaptureBody [star] star (Handler star) + -- ^ Augment a 'Handler' to include requirements of a request body. + | CaptureHeaders [(HeaderName, star)] (Handler star) + -- ^ Augment a 'Handler' to include requirements of request header values. + | CaptureQuery [(Symbol, star)] (Handler star) + -- ^ Augment a 'Handler' to include requirements of the request query + -- string + +data instance Sing (h :: Handler *) + = forall v ts . h ~ Method v ts => SMethod (Sing v) (Sing ts) + | forall ts a k . h ~ CaptureBody ts a k => SCaptureBody (Sing ts) (Sing a) (Sing k) + | forall ts k . h ~ CaptureHeaders ts k => SCaptureHeaders (Sing ts) (Sing k) + | forall ts k . h ~ CaptureQuery ts k => SCaptureQuery (Sing ts) (Sing k) + +instance (SingI v, SingI ts) => SingI ('Method v ts :: Handler *) where + sing = SMethod sing sing + +instance (SingI ts, SingI a, SingI k) => SingI ('CaptureBody ts a k :: Handler *) where + sing = SCaptureBody sing sing sing + +instance (SingI ts, SingI k) => SingI ('CaptureHeaders ts k :: Handler *) where + sing = SCaptureHeaders sing sing + +instance (SingI ts, SingI k) => SingI ('CaptureQuery ts k :: Handler *) where + sing = SCaptureQuery sing sing + +type Method verb responses = 'Method verb responses +type CaptureBody cTypes ty method = 'CaptureBody cTypes ty method +type CaptureHeaders hdrs method = 'CaptureHeaders hdrs method +type CaptureQuery query method = 'CaptureQuery query method + + + + +-- | "Generalized" path segments match against data in the request. +data Path star + = Const Symbol + -- ^ Matches if the request has a non-empty remaining path and the next + -- segment matches exactly + | HeaderAs HeaderName Symbol + -- ^ Matches if the request has a given header and its value matches + -- exactly (!) + | Seg Symbol star + -- ^ Matches if the request has a non-empty remaining path. The next + -- segment is "captured", provided to the server implementation. + | Header HeaderName star + -- ^ Always matches, "capturing" the value of a header, or 'Nothing' if + -- the header fails to exist. + | Wildcard + -- ^ Always matches, "captures" the remaining path segments as a list + -- of text values. May just capture the empty list. + +data instance Sing (p :: Path *) + = forall s . p ~ Const s => SConst (Sing s) + | forall n v . p ~ HeaderAs n v => SHeaderAs (Sing n) (Sing v) + | forall n t . p ~ Seg n t => SSeg (Sing n) (Sing t) + | forall n t . p ~ Header n t => SHeader (Sing n) (Sing t) + | p ~ Wildcard => SWildcard + +instance SingI s => SingI (Const s :: Path *) where + sing = SConst sing + +instance (SingI n, SingI v) => SingI (HeaderAs n v :: Path *) where + sing = SHeaderAs sing sing + +instance (SingI n, SingI t) => SingI (Seg n t :: Path *) where + sing = SSeg sing sing + +instance (SingI n, SingI t) => SingI (Header n t :: Path *) where + sing = SHeader sing sing + +instance SingI (Wildcard :: Path *) where + sing = SWildcard + +type Const sym = 'Const sym +type HeaderAs ty sym = 'HeaderAs ty sym +type Seg sym ty = 'Seg sym ty +type Header name ty = 'Header name ty +type Wildcard = 'Wildcard + + + + +-- | 'Api's describe collections of HTTP endpoints accessible at +-- various segmented 'Path's. +data Api star + = Endpoint star [Handler star] + -- ^ 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. + | OneOf [Api star] + -- ^ '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@. + | Abstract + -- ^ 'Abstract' 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. + | Path star :> Api star + -- ^ Qualify an API using a series of 'Path' "segments" +infixr 5 :> + +data instance Sing (a :: Api *) + = forall t ts . a ~ Endpoint t ts => SEndpoint (Sing t) (Sing ts) + | forall ts . a ~ OneOf ts => SOneOf (Sing ts) + | a ~ Abstract => SAbstract + | forall p k . a ~ (p :> k) => Sing p :%> Sing k + +instance (SingI t, SingI ts) => SingI ('Endpoint t ts :: Api *) where + sing = SEndpoint sing sing + +instance SingI ts => SingI ('OneOf ts :: Api *) where + sing = SOneOf sing + +instance SingI (Abstract :: Api *) where + sing = SAbstract + +instance (SingI p, SingI k) => SingI (p :> k :: Api *) where + sing = sing :%> sing + +type Endpoint ann ms = 'Endpoint ann ms +type OneOf apis = 'OneOf apis +type Abstract = 'Abstract +type a :> b = a ':> b + diff --git a/src/Serv/Api/Analysis.hs b/src/Serv/Api/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Api/Analysis.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Typeclasses constructing functions which reflect and analyze API +-- types. +-- +-- (/A little rough right now, sorry/) +module Serv.Api.Analysis where + +import Data.Monoid +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Singletons +import Data.Singletons.Prelude.List +import Data.Singletons.Prelude.Tuple +import Network.HTTP.Kinder.Header (HeaderName, SomeHeaderName (..)) +import Network.HTTP.Kinder.Verb (Verb) +import Serv.Api + +data EndpointAnalysis + = EndpointAnalysis + { verbsHandled :: Set Verb + , headersExpected :: Set SomeHeaderName + , headersEmitted :: Set SomeHeaderName + } + +instance Monoid EndpointAnalysis where + mempty = EndpointAnalysis mempty mempty mempty + mappend ea eb = + EndpointAnalysis + { verbsHandled = verbsHandled ea <> verbsHandled eb + , headersExpected = headersExpected ea <> headersExpected eb + , headersEmitted = headersEmitted ea <> headersEmitted eb + } + +inspectEndpoint :: forall (hs :: [Handler *]) . Sing hs -> EndpointAnalysis +inspectEndpoint s = + case s of + SNil -> mempty + SCons sHandler sRest -> inspectHandler sHandler <> inspectEndpoint sRest + +inspectHandler :: forall (h :: Handler *) . Sing h -> EndpointAnalysis +inspectHandler s = + case s of + SCaptureQuery _ sNext -> inspectHandler sNext + SCaptureBody _ _ sNext -> inspectHandler sNext + SMethod sVerb sResponses -> + case sResponses of + SNil -> mempty + SCons (STuple2 _sCode (SRespond sHdrs _sBody)) sRest -> + EndpointAnalysis + { verbsHandled = Set.singleton (fromSing sVerb) + , headersEmitted = headerNames sHdrs + , headersExpected = Set.empty + } <> inspectHandler (SMethod sVerb sRest) + SCaptureHeaders sHdrs sNext -> + EndpointAnalysis + { verbsHandled = Set.empty + , headersEmitted = Set.empty + , headersExpected = headerNames sHdrs + } + <> inspectHandler sNext + +headerNames :: forall (hts :: [(HeaderName, k)]) . Sing hts -> Set SomeHeaderName +headerNames s = + case s of + SNil -> Set.empty + SCons (STuple2 sHt _sTy) sRest -> + Set.insert (SomeHeaderName sHt) (headerNames sRest) + +inspectVerbs :: forall (hs :: [Handler *]) . Sing hs -> Set Verb +inspectVerbs = verbsHandled . inspectEndpoint + +headersExpectedOf :: forall (hs :: [Handler *]) . Sing hs -> Set SomeHeaderName +headersExpectedOf = headersExpected . inspectEndpoint diff --git a/src/Serv/Api/Prelude.hs b/src/Serv/Api/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Api/Prelude.hs @@ -0,0 +1,19 @@ + +-- | Module containing everything you need to define an 'Api' type. Import +-- this unqualified for easy 'Api' definitions. +-- +-- Exports the instance of 'SingI' for all 'Typeable' types. This will +-- cause issues for @CustomStar@-style 'SingI' instances, but is nearly +-- required for Serv. +module Serv.Api.Prelude ( + + module Serv.Api + , module Network.HTTP.Kinder + , SingI (..) + +) where + +import Data.Singletons +import Data.Singletons.TypeRepStar () +import Network.HTTP.Kinder +import Serv.Api diff --git a/src/Serv/Common.hs b/src/Serv/Common.hs deleted file mode 100644 --- a/src/Serv/Common.hs +++ /dev/null @@ -1,4 +0,0 @@ - -module Serv.Common ( RawText (..) ) where - -import Serv.Internal.RawText diff --git a/src/Serv/ContentType.hs b/src/Serv/ContentType.hs deleted file mode 100644 --- a/src/Serv/ContentType.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Cors.hs +++ /dev/null @@ -1,17 +0,0 @@ - -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 deleted file mode 100644 --- a/src/Serv/Header.hs +++ /dev/null @@ -1,12 +0,0 @@ - -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 deleted file mode 100644 --- a/src/Serv/Header/Proxies.hs +++ /dev/null @@ -1,75 +0,0 @@ - -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 deleted file mode 100644 --- a/src/Serv/Internal/Api.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Api/Analysis.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Cors.hs +++ /dev/null @@ -1,127 +0,0 @@ - -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 deleted file mode 100644 --- a/src/Serv/Internal/Header.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Header/Name.hs +++ /dev/null @@ -1,725 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Header/Serialization.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/MediaType.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Pair.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Query.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/RawText.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Rec.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Server.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Server/Config.hs +++ /dev/null @@ -1,8 +0,0 @@ - -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 deleted file mode 100644 --- a/src/Serv/Internal/Server/Context.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/Server/Error.hs +++ /dev/null @@ -1,17 +0,0 @@ - -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 deleted file mode 100644 --- a/src/Serv/Internal/Server/Type.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Internal/URI.hs +++ /dev/null @@ -1,21 +0,0 @@ - -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 deleted file mode 100644 --- a/src/Serv/Internal/Verb.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Serv/Server.hs +++ /dev/null @@ -1,44 +0,0 @@ - -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 deleted file mode 100644 --- a/src/Serv/URI.hs +++ /dev/null @@ -1,9 +0,0 @@ - -module Serv.URI ( - - URIEncode (..) - , URIDecode (..) - - ) where - -import Serv.Internal.URI diff --git a/test/Examples/Ex1.hs b/test/Examples/Ex1.hs deleted file mode 100644 --- a/test/Examples/Ex1.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/Examples/Ex2.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,33 +0,0 @@ - -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