serv 0.1.0.0 → 0.2.0.0

raw patch · 33 files changed

+350/−2844 lines, 33 filesdep +http-kinderdep +singletonsdep −HUnitdep −QuickCheckdep −aesondep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: http-kinder, singletons

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

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• app/TestServer.hs +0/−42
• serv.cabal +20/−72
• src/Serv/Api.hs +230/−8
• src/Serv/Api/Analysis.hs +81/−0
• src/Serv/Api/Prelude.hs +19/−0
• src/Serv/Common.hs +0/−4
• src/Serv/ContentType.hs +0/−43
• src/Serv/Cors.hs +0/−17
• src/Serv/Header.hs +0/−12
• src/Serv/Header/Proxies.hs +0/−75
• src/Serv/Internal/Api.hs +0/−106
• src/Serv/Internal/Api/Analysis.hs +0/−110
• src/Serv/Internal/Cors.hs +0/−127
• src/Serv/Internal/Header.hs +0/−64
• src/Serv/Internal/Header/Name.hs +0/−725
• src/Serv/Internal/Header/Serialization.hs +0/−130
• src/Serv/Internal/MediaType.hs +0/−86
• src/Serv/Internal/Pair.hs +0/−11
• src/Serv/Internal/Query.hs +0/−50
• src/Serv/Internal/RawText.hs +0/−16
• src/Serv/Internal/Rec.hs +0/−52
• src/Serv/Internal/Server.hs +0/−319
• src/Serv/Internal/Server/Config.hs +0/−8
• src/Serv/Internal/Server/Context.hs +0/−178
• src/Serv/Internal/Server/Error.hs +0/−17
• src/Serv/Internal/Server/Type.hs +0/−221
• src/Serv/Internal/URI.hs +0/−21
• src/Serv/Internal/Verb.hs +0/−42
• src/Serv/Server.hs +0/−44
• src/Serv/URI.hs +0/−9
• test/Examples/Ex1.hs +0/−111
• test/Examples/Ex2.hs +0/−91
• test/Spec.hs +0/−33

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -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: <delta-seconds>--  | AccessControlAllowCredentials-    -- ^ Indicates whether or not the response to the request can be exposed when the-    -- credentials flag is true. When used as part of a response to a preflight request,-    -- this indicates whether or not the actual request can be made using credentials. Note-    -- that simple GET requests are not preflighted, and so if a request is made for a-    -- resource with credentials, if this header is not returned with the resource, the-    -- response is ignored by the browser and not returned to web content.-    ---    --     Access-Control-Allow-Credentials: true | false--  | AccessControlAllowMethods-    -- ^ Specifies the method or methods allowed when accessing the resource. This is-    -- used in response to a preflight request.-    ---    --     Access-Control-Allow-Methods: <method>[, <method>]*--  | AccessControlAllowHeaders-    -- ^ Used in response to a preflight request to indicate which HTTP headers can-    -- be used when making the actual request.--  | AcceptPatch-    -- ^ Specifies which patch document formats this server supports-    ---    --     Accept-Patch: text/example;charset=utf-8--  | AcceptRanges-    -- ^ What partial content range types this server supports via byte serving-    ---    --     Accept-Ranges: bytes--  | Age-    -- ^ The age the object has been in a proxy cache in seconds-    ---    --     Age: 12--  | Allow-    -- ^ Valid actions for a specified resource. To be used for a 405 Method not allowed-    ---    --     Allow: GET, HEAD--  | ContentDisposition-    -- ^ An opportunity to raise a "File Download" dialogue box for a known MIME type-    -- with binary format or suggest a filename for dynamic content. Quotes are-    -- necessary with special characters.-    ---    --     Content-Disposition: attachment; filename="fname.ext"--  | ContentEncoding-    -- ^ The type of encoding used on the data.-    ---    --     Content-Encoding: gzip--  | ContentLanguage-    -- ^ The natural language or languages of the intended audience for the enclosed content-    ---    --     Content-Language: da--  | ContentLocation-    -- ^ An alternate location for the returned data-    ---    --     Content-Location: /index.htm--  | ContentRange-    -- ^ Where in a full body message this partial message belongs-    ---    --     Content-Range: bytes 21010-47021/47022--  | ContentSecurityPolicy-    -- ^ Content Security Policy definition.-    ---    --     Content-Security-Policy: default-src 'self'--  | ETag-    -- ^ An identifier for a specific version of a resource, often a message digest-    ---    --     ETag: "737060cd8c284d8af7ad3082f209582d"--  | Expires-    -- ^ Gives the date/time after which the response is considered stale (in-    -- "HTTP-date" format as defined by RFC 7231)-    ---    --     Expires: Thu, 01 Dec 1994 16:00:00 GMT--  | LastModified-    -- ^ The last modified date for the requested object (in "HTTP-date" format as-    -- defined by RFC 7231)-    ---    --     Last-Modified: Tue, 15 Nov 1994 12:45:26 GMT--  | Link-    -- ^ Used to express a typed relationship with another resource, where the-    -- relation type is defined by RFC 5988-    ---    --     Link: </feed>; rel="alternate"--  | Location-    -- ^ Used in redirection, or when a new resource has been created.-    ---    --     Location: http://www.w3.org/pub/WWW/People.html--  | ProxyAuthenticate-    -- ^ Request authentication to access the proxy.-    ---    --     Proxy-Authenticate: Basic--  | PublicKeyPins-    -- ^ HTTP Public Key Pinning, announces hash of website's authentic TLS certificate-    ---    --     Public-Key-Pins: max-age=2592000; pin-sha256="E9CZ9INDbd+2eRQozYqqbQ2yXLVKB9+xcprMF+44U1g=";--  | RetryAfter-    -- ^ If an entity is temporarily unavailable, this instructs the client to-    -- try again later. Value could be a specified period of time (in seconds) or a HTTP-date.-    ---    --     Retry-After: 120-    --     Retry-After: Fri, 07 Nov 2014 23:59:59 GMT--  | SetCookie-    -- ^ An HTTP cookie-    ---    --     Set-Cookie: UserID=JohnDoe; Max-Age=3600; Version=1--  | StrictTransportSecurity-    -- ^ A HSTS Policy informing the HTTP client how long to cache the HTTPS only-    -- policy and whether this applies to subdomains.-    ---    --     Strict-Transport-Security: max-age=16070400; includeSubDomains--  | Trailer-    -- ^ The Trailer general field value indicates that the given set of header fields-    -- is present in the trailer of a message encoded with chunked transfer coding.-    ---    --     Trailer: Max-Forwards--  | TransferEncoding-    -- ^ The form of encoding used to safely transfer the entity to the user. Currently defined-    -- methods are: chunked, compress, deflate, gzip, identity.-    ---    --     Transfer-Encoding: chunked--  | Vary-    -- ^ Tells downstream proxies how to match future request headers to decide whether-    -- the cached response can be used rather than requesting a fresh one from the origin server.-    ---    --     Vary: *-    --     Vary: Accept-Language--  | WWWAuthenticate-    -- ^ Indicates the authentication scheme that should be used to access the requested entity.-    ---    --     WWW-Authenticate: Basic---- | Implements reflection of 'Name' types into 'HTTP.HeaderName' values for runtime use.-class ReflectName (n :: HeaderName) where-  reflectName :: proxy n -> HTTP.HeaderName----- Proxies--- ------------------------------------------------------------------------------cacheControl :: Proxy 'CacheControl-cacheControl = Proxy--connection :: Proxy 'Connection-connection = Proxy--contentLength :: Proxy 'ContentLength-contentLength = Proxy--contentType :: Proxy 'ContentType-contentType = Proxy--date :: Proxy 'Date-date = Proxy--pragma :: Proxy 'Pragma-pragma = Proxy--upgrade :: Proxy 'Upgrade-upgrade = Proxy--via :: Proxy 'Via-via = Proxy--warning :: Proxy 'Warning-warning = Proxy--accept :: Proxy 'Accept-accept = Proxy--acceptCharset :: Proxy 'AcceptCharset-acceptCharset = Proxy--acceptEncoding :: Proxy 'AcceptEncoding-acceptEncoding = Proxy--acceptLanguage :: Proxy 'AcceptLanguage-acceptLanguage = Proxy--accessControlRequestMethod :: Proxy 'AccessControlRequestMethod-accessControlRequestMethod = Proxy--accessControlRequestHeaders :: Proxy 'AccessControlRequestHeaders-accessControlRequestHeaders = Proxy--authorization :: Proxy 'Authorization-authorization = Proxy--cookie :: Proxy 'Cookie-cookie = Proxy--expect :: Proxy 'Expect-expect = Proxy--from :: Proxy 'From-from = Proxy--host :: Proxy 'Host-host = Proxy--ifMatch :: Proxy 'IfMatch-ifMatch = Proxy--ifModifiedSince :: Proxy 'IfModifiedSince-ifModifiedSince = Proxy--ifNoneMatch :: Proxy 'IfNoneMatch-ifNoneMatch = Proxy--ifRange :: Proxy 'IfRange-ifRange = Proxy--ifUnmodifiedSince :: Proxy 'IfUnmodifiedSince-ifUnmodifiedSince = Proxy--maxForwards :: Proxy 'MaxForwards-maxForwards = Proxy--origin :: Proxy 'Origin-origin = Proxy--proxyAuthorization :: Proxy 'ProxyAuthorization-proxyAuthorization = Proxy--range :: Proxy 'Range-range = Proxy--referer :: Proxy 'Referer-referer = Proxy--tE :: Proxy 'TE-tE = Proxy--userAgent :: Proxy 'UserAgent-userAgent = Proxy--xForwardedFor :: Proxy 'XForwardedFor-xForwardedFor = Proxy--xForwardedHost :: Proxy 'XForwardedHost-xForwardedHost = Proxy--xForwardedProto :: Proxy 'XForwardedProto-xForwardedProto = Proxy--xCsrfToken :: Proxy 'XCsrfToken-xCsrfToken = Proxy--accessControlAllowOrigin :: Proxy 'AccessControlAllowOrigin-accessControlAllowOrigin = Proxy--accessControlExposeHeaders :: Proxy 'AccessControlExposeHeaders-accessControlExposeHeaders = Proxy--accessControlMaxAge :: Proxy 'AccessControlMaxAge-accessControlMaxAge = Proxy--accessControlAllowCredentials :: Proxy 'AccessControlAllowCredentials-accessControlAllowCredentials = Proxy--accessControlAllowMethods :: Proxy 'AccessControlAllowMethods-accessControlAllowMethods = Proxy--accessControlAllowHeaders :: Proxy 'AccessControlAllowHeaders-accessControlAllowHeaders = Proxy--acceptPatch :: Proxy 'AcceptPatch-acceptPatch = Proxy--acceptRanges :: Proxy 'AcceptRanges-acceptRanges = Proxy--age :: Proxy 'Age-age = Proxy--allow :: Proxy 'Allow-allow = Proxy--contentDisposition :: Proxy 'ContentDisposition-contentDisposition = Proxy--contentEncoding :: Proxy 'ContentEncoding-contentEncoding = Proxy--contentLanguage :: Proxy 'ContentLanguage-contentLanguage = Proxy--contentLocation :: Proxy 'ContentLocation-contentLocation = Proxy--contentRange :: Proxy 'ContentRange-contentRange = Proxy--contentSecurityPolicy :: Proxy 'ContentSecurityPolicy-contentSecurityPolicy = Proxy--eTag :: Proxy 'ETag-eTag = Proxy--expires :: Proxy 'Expires-expires = Proxy--lastModified :: Proxy 'LastModified-lastModified = Proxy--link :: Proxy 'Link-link = Proxy--location :: Proxy 'Location-location = Proxy--proxyAuthenticate :: Proxy 'ProxyAuthenticate-proxyAuthenticate = Proxy--publicKeyPins :: Proxy 'PublicKeyPins-publicKeyPins = Proxy--retryAfter :: Proxy 'RetryAfter-retryAfter = Proxy--setCookie :: Proxy 'SetCookie-setCookie = Proxy--strictTransportSecurity :: Proxy 'StrictTransportSecurity-strictTransportSecurity = Proxy--trailer :: Proxy 'Trailer-trailer = Proxy--transferEncoding :: Proxy 'TransferEncoding-transferEncoding = Proxy--vary :: Proxy 'Vary-vary = Proxy--wWWAuthenticate :: Proxy 'WWWAuthenticate-wWWAuthenticate = Proxy----- ReflectName Instances------ A very verbose way of matching on lots of simple types. Not really worth--- your time reading. Heavy potential for bugs.--- -------------------------------------------------------------------------------instance KnownSymbol s => ReflectName ('HeaderName s) where-  reflectName _ = fromString (symbolVal (Proxy :: Proxy s))--instance ReflectName 'CacheControl where reflectName _ = "Cache-Control"-instance ReflectName 'Connection where reflectName _ = "Connection"-instance ReflectName 'ContentLength where reflectName _ = "Content-Length"-instance ReflectName 'ContentType where reflectName _ = "Content-Type"-instance ReflectName 'Date where reflectName _ = "Date"-instance ReflectName 'Pragma where reflectName _ = "Pragma"-instance ReflectName 'Upgrade where reflectName _ = "Upgrade"-instance ReflectName 'Via where reflectName _ = "Via"-instance ReflectName 'Warning where reflectName _ = "Warning"-instance ReflectName 'Accept where reflectName _ = "Accept"-instance ReflectName 'AcceptCharset where reflectName _ = "Accept-Charset"-instance ReflectName 'AcceptEncoding where reflectName _ = "Accept-Encoding"-instance ReflectName 'AcceptLanguage where reflectName _ = "Accept-Language"-instance ReflectName 'AccessControlRequestMethod where reflectName _ = "Access-Control-Request-Method"-instance ReflectName 'AccessControlRequestHeaders where reflectName _ = "Access-Control-Request-Headers"-instance ReflectName 'Authorization where reflectName _ = "Authorization"-instance ReflectName 'Cookie where reflectName _ = "Cookie"-instance ReflectName 'Expect where reflectName _ = "Expect"-instance ReflectName 'From where reflectName _ = "From"-instance ReflectName 'Host where reflectName _ = "Host"-instance ReflectName 'IfMatch where reflectName _ = "If-Match"-instance ReflectName 'IfModifiedSince where reflectName _ = "If-Modified-Since"-instance ReflectName 'IfNoneMatch where reflectName _ = "If-None-Match"-instance ReflectName 'IfRange where reflectName _ = "If-Range"-instance ReflectName 'IfUnmodifiedSince where reflectName _ = "If-Unmodified-Since"-instance ReflectName 'MaxForwards where reflectName _ = "Max-Forwards"-instance ReflectName 'Origin where reflectName _ = "Origin"-instance ReflectName 'ProxyAuthorization where reflectName _ = "Proxy-Authorization"-instance ReflectName 'Range where reflectName _ = "Range"-instance ReflectName 'Referer where reflectName _ = "Referer"-instance ReflectName 'TE where reflectName _ = "TE"-instance ReflectName 'UserAgent where reflectName _ = "User-Agent"-instance ReflectName 'XForwardedFor where reflectName _ = "X-Forwarded-For"-instance ReflectName 'XForwardedHost where reflectName _ = "X-Forwarded-Host"-instance ReflectName 'XForwardedProto where reflectName _ = "X-Forwarded-Proto"-instance ReflectName 'XCsrfToken where reflectName _ = "X-Csrf-Token"-instance ReflectName 'AccessControlAllowOrigin where reflectName _ = "Access-Control-Allow-Origin"-instance ReflectName 'AccessControlExposeHeaders where reflectName _ = "Access-Control-Expose-Headers"-instance ReflectName 'AccessControlMaxAge where reflectName _ = "Access-Control-Max-Age"-instance ReflectName 'AccessControlAllowCredentials where reflectName _ = "Access-Control-Allow-Credentials"-instance ReflectName 'AccessControlAllowMethods where reflectName _ = "Access-Control-Allow-Methods"-instance ReflectName 'AccessControlAllowHeaders where reflectName _ = "Access-Control-Allow-Headers"-instance ReflectName 'AcceptPatch where reflectName _ = "Accept-Patch"-instance ReflectName 'AcceptRanges where reflectName _ = "Accept-Ranges"-instance ReflectName 'Age where reflectName _ = "Age"-instance ReflectName 'Allow where reflectName _ = "Allow"-instance ReflectName 'ContentDisposition where reflectName _ = "Content-Disposition"-instance ReflectName 'ContentEncoding where reflectName _ = "Content-Encoding"-instance ReflectName 'ContentLanguage where reflectName _ = "Content-Language"-instance ReflectName 'ContentLocation where reflectName _ = "Content-Location"-instance ReflectName 'ContentRange where reflectName _ = "Content-Range"-instance ReflectName 'ContentSecurityPolicy where reflectName _ = "Content-Security-Policy"-instance ReflectName 'ETag where reflectName _ = "ETag"-instance ReflectName 'Expires where reflectName _ = "Expires"-instance ReflectName 'LastModified where reflectName _ = "Last-Modified"-instance ReflectName 'Link where reflectName _ = "Link"-instance ReflectName 'Location where reflectName _ = "Location"-instance ReflectName 'ProxyAuthenticate where reflectName _ = "Proxy-Authenticate"-instance ReflectName 'PublicKeyPins where reflectName _ = "Public-Key-Pins"-instance ReflectName 'RetryAfter where reflectName _ = "Retry-After"-instance ReflectName 'SetCookie where reflectName _ = "Set-Cookie"-instance ReflectName 'StrictTransportSecurity where reflectName _ = "Strict-Transport-Security"-instance ReflectName 'Trailer where reflectName _ = "Trailer"-instance ReflectName 'TransferEncoding where reflectName _ = "Transfer-Encoding"-instance ReflectName 'Vary where reflectName _ = "Vary"-instance ReflectName 'WWWAuthenticate where reflectName _ = "WWW-Authenticate"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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