servant-snap 0.7.3 → 0.8

raw patch · 8 files changed

+316/−86 lines, 8 filesdep +word8dep ~basedep ~base64-bytestringdep ~io-streamsPVP ok

version bump matches the API change (PVP)

Dependencies added: word8

Dependency ranges changed: base, base64-bytestring, io-streams

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• example/greet.hs +1/−1
• servant-snap.cabal +7/−2
• src/Servant/Server.hs +23/−6
• src/Servant/Server/Internal.hs +104/−76
• src/Servant/Server/Internal/BasicAuth.hs +73/−0
• src/Servant/Server/Internal/Context.hs +102/−0
• src/Servant/Utils/StaticFiles.hs +1/−1

@@ -1,3 +1,8 @@+0.8+-------++Copy BasicAuth and Context from servant-server to support basic auth checking+ 0.7.1 ------- 

@@ -78,7 +78,7 @@ -- -- Each handler runs in the 'AppHandler' monad. -server :: Server (TestApi AppHandler) AppHandler+server :: Server (TestApi AppHandler) '[] AppHandler server = helloH     :<|> helloH'     :<|> postGreetH

@@ -1,5 +1,5 @@ name:                servant-snap-version:             0.7.3+version:             0.8 synopsis:            A family of combinators for defining webservices APIs and serving them description:   Interpret a Servant API as a Snap server, using any Snaplets you like.@@ -36,6 +36,8 @@     Servant.Server     Servant.Server.Internal     Servant.Server.Internal.PathInfo+    Servant.Server.Internal.BasicAuth+    Servant.Server.Internal.Context     Servant.Server.Internal.Router     Servant.Server.Internal.RoutingApplication     Servant.Server.Internal.ServantErr@@ -45,6 +47,7 @@         base               >= 4.7  && < 4.11       , aeson              >= 0.7  && < 1.3       , attoparsec         >= 0.12 && < 0.14+      , base64-bytestring  >= 1.0  && < 1.1       , bytestring         >= 0.10 && < 0.11       , case-insensitive   >= 1.2  && < 1.3       , containers         >= 0.5  && < 0.6@@ -52,7 +55,7 @@       , filepath           >= 1    && < 1.5       , http-types         >= 0.8  && < 0.10       , http-api-data      >= 0.2  && < 0.4-      , io-streams         >= 1.3  && < 1.4+      , io-streams         >= 1.3  && < 1.5       , network-uri        >= 2.6  && < 2.7       , mtl                >= 2.0  && < 2.3       , mmorph             >= 1    && < 1.2@@ -63,6 +66,7 @@       , snap-core          >= 1.0  && < 1.1       , snap-server        >= 1.0  && < 1.1       , transformers       >= 0.3  && < 0.6+      , word8              >= 0.1  && < 0.2   hs-source-dirs: src   default-language: Haskell2010   ghc-options: -Wall@@ -107,6 +111,7 @@     , either     , exceptions     , hspec              >= 2.4.3   && < 2.5+    , lens     , process     , digestive-functors >= 0.8.1.0 && < 0.9     , time

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes        #-}@@ -9,11 +10,16 @@ module Servant.Server   ( -- * Run a snap handler from an API     serveSnap+  , serveSnapWithContext    , -- * Handlers for all standard combinators     HasServer(..)   , Server +  , -- * Reexports+    module Servant.Server.Internal.BasicAuth+  , module Servant.Server.Internal.Context+     -- ** Basic functions and datatypes      -- * Default error type@@ -57,6 +63,8 @@  import           Data.Proxy                        (Proxy(..)) import           Servant.Server.Internal+import           Servant.Server.Internal.BasicAuth+import           Servant.Server.Internal.Context import           Servant.Server.Internal.SnapShims import           Snap.Core                         hiding (route) @@ -86,15 +94,24 @@ --  serveApplication-  :: forall layout m.(HasServer layout, MonadSnap m)+  :: forall layout context m.(HasServer layout context m, MonadSnap m)   => Proxy layout-  -> Server layout m+  -> Context context+  -> Server layout context m   -> Application m-serveApplication p server = toApplication (runRouter (route p (emptyDelayed (Proxy :: Proxy (m :: * -> *)) ((Route server)))))+serveApplication p ctx server = toApplication (runRouter (route p ctx (emptyDelayed (Proxy :: Proxy (m :: * -> *)) ((Route server))))) +serveSnapWithContext+  :: forall layout context m.(HasServer layout context m, MonadSnap m)+  => Proxy layout+  -> Context context+  -> Server layout context m+  -> m ()+serveSnapWithContext p ctx server = applicationToSnap $ serveApplication p ctx server+ serveSnap-  :: forall layout m.(HasServer layout, MonadSnap m)+  :: forall layout m.(HasServer layout '[] m, MonadSnap m)   => Proxy layout-  -> Server layout m+  -> Server layout '[] m   -> m ()-serveSnap p server = applicationToSnap $ serveApplication p server+serveSnap p server = serveSnapWithContext p EmptyContext server

@@ -1,5 +1,7 @@ {-# LANGUAGE CPP                  #-} {-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE DeriveGeneric        #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -33,6 +35,7 @@ import           Data.String                 (fromString) import           Data.String.Conversions     (cs, (<>)) import           Data.Text                   (Text)+import           GHC.Generics import           GHC.TypeLits                (KnownNat, KnownSymbol, natVal,                                               symbolVal) import           Network.HTTP.Types          (HeaderName, Method,@@ -47,7 +50,8 @@ import           Snap.Core                   hiding (Headers, Method,                                               getResponse, headers, route,                                               method, withRequest)-import           Servant.API                 ((:<|>) (..), (:>), Capture,+import           Servant.API                 ((:<|>) (..), (:>), BasicAuth,+                                              Capture,                                               CaptureAll, Header,                                               IsSecure(..), QueryFlag,                                               QueryParam, QueryParams, Raw,@@ -60,21 +64,25 @@                                               getHeaders) -- import           Servant.Common.Text         (FromText, fromText) +import           Servant.Server.Internal.BasicAuth+import           Servant.Server.Internal.Context import           Servant.Server.Internal.PathInfo import           Servant.Server.Internal.Router import           Servant.Server.Internal.RoutingApplication import           Servant.Server.Internal.ServantErr import           Servant.Server.Internal.SnapShims -class HasServer api where-  type ServerT api (m :: * -> *) :: *+-- TODO: add MonadSnap m => m ?+class HasServer api context (m :: * -> *) where+  type ServerT api context m :: *    route :: MonadSnap m         => Proxy api-        -> Delayed m env (Server api m)+        -> Context context+        -> Delayed m env (Server api context m)         -> Router m env -type Server api m = ServerT api m+type Server api context m = ServerT api context m  -- * Instances @@ -89,12 +97,12 @@ -- > server = listAllBooks :<|> postBook -- >   where listAllBooks = ... -- >         postBook book = ...-instance (HasServer a, HasServer b) => HasServer (a :<|> b) where+instance (HasServer a ctx m, HasServer b ctx m) => HasServer (a :<|> b) ctx m where -  type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m+  type ServerT (a :<|> b) ctx m = ServerT a ctx m :<|> ServerT b ctx m -  route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))-                              (route pb ((\ (_ :<|> b) -> b) <$> server))+  route Proxy ctx server = choice (route pa ctx ((\ (a :<|> _) -> a) <$> server))+                                  (route pb ctx ((\ (_ :<|> b) -> b) <$> server))     where pa = Proxy :: Proxy a           pb = Proxy :: Proxy b @@ -118,30 +126,30 @@ -- > server = getBook -- >   where getBook :: Text -> EitherT ServantErr IO Book -- >         getBook isbn = ...-instance (FromHttpApiData a, HasServer sublayout)-      => HasServer (Capture capture a :> sublayout) where+instance (FromHttpApiData a, HasServer sublayout context m)+      => HasServer (Capture capture a :> sublayout) context m where -  type ServerT (Capture capture a :> sublayout) m =-     a -> ServerT sublayout m+  type ServerT (Capture capture a :> sublayout) context m =+     a -> ServerT sublayout context m -  route Proxy d =+  route Proxy ctx d =     CaptureRouter $-      route (Proxy :: Proxy sublayout)+      route (Proxy :: Proxy sublayout) ctx         (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of                                    Nothing -> delayedFail err400                                    Just v  -> return v         )  -instance (FromHttpApiData a, HasServer sublayout)-      => HasServer (CaptureAll capture a :> sublayout) where+instance (FromHttpApiData a, HasServer sublayout context m)+      => HasServer (CaptureAll capture a :> sublayout) context m where -  type ServerT (CaptureAll capture a :> sublayout) m =-    [a] -> ServerT sublayout m+  type ServerT (CaptureAll capture a :> sublayout) context m =+    [a] -> ServerT sublayout context m -  route Proxy d =+  route Proxy ctx d =     CaptureAllRouter $-        route (Proxy :: Proxy sublayout)+        route (Proxy :: Proxy sublayout) ctx               (addCapture d $ \ txts -> case parseUrlPieces txts of                  Left _  -> delayedFail err400                  Right v -> return v@@ -219,9 +227,9 @@ instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a,                                ReflectMethod method,                                KnownNat status)-  => HasServer (Verb method status ctypes a) where-  type ServerT (Verb method status ctypes  a) m = m a-  route Proxy = methodRouter method (Proxy :: Proxy ctypes) status+  => HasServer (Verb method status ctypes a) context m where+  type ServerT (Verb method status ctypes  a) context m = m a+  route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status     where method = reflectMethod (Proxy :: Proxy method)           status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) @@ -229,10 +237,10 @@                                ReflectMethod method,                                KnownNat status,                                GetHeaders (Headers h a))-  => HasServer (Verb method status ctypes (Headers h a)) where+  => HasServer (Verb method status ctypes (Headers h a)) context m where -  type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)-  route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status+  type ServerT (Verb method status ctypes (Headers h a)) context m = m (Headers h a)+  route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status     where method = reflectMethod (Proxy :: Proxy method)           status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) @@ -258,15 +266,15 @@ -- > server = viewReferer -- >   where viewReferer :: Referer -> EitherT ServantErr IO referer -- >         viewReferer referer = return referer-instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)-      => HasServer (Header sym a :> sublayout) where+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context m)+      => HasServer (Header sym a :> sublayout) context m where -  type ServerT (Header sym a :> sublayout) m =-    Maybe a -> ServerT sublayout m+  type ServerT (Header sym a :> sublayout) context m =+    Maybe a -> ServerT sublayout context m -  route Proxy subserver =+  route Proxy ctx subserver =     let mheader req = parseHeaderMaybe =<< getHeader str req-    in  route (Proxy :: Proxy sublayout) (passToServer subserver mheader)+    in  route (Proxy :: Proxy sublayout) ctx (passToServer subserver mheader)     where str = fromString $ symbolVal (Proxy :: Proxy sym)  @@ -291,13 +299,13 @@ -- >   where getBooksBy :: Maybe Text -> EitherT ServantErr IO [Book] -- >         getBooksBy Nothing       = ...return all books... -- >         getBooksBy (Just author) = ...return books by the given author...-instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)-      => HasServer (QueryParam sym a :> sublayout) where+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context m)+      => HasServer (QueryParam sym a :> sublayout) context m where -  type ServerT (QueryParam sym a :> sublayout) m =-    Maybe a -> ServerT sublayout m+  type ServerT (QueryParam sym a :> sublayout) context m =+    Maybe a -> ServerT sublayout context m -  route Proxy subserver =+  route Proxy ctx subserver =     let querytext r = parseQueryText $ rqQueryString r         param r =           case lookup paramname (querytext r) of@@ -305,7 +313,7 @@             Just Nothing  -> Nothing -- param present with no value -> Nothing             Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to                                         -- the right type-    in route (Proxy :: Proxy sublayout) (passToServer subserver param)+    in route (Proxy :: Proxy sublayout) ctx (passToServer subserver param)     where paramname = cs $ symbolVal (Proxy :: Proxy sym)  @@ -328,20 +336,20 @@ -- > server = getBooksBy -- >   where getBooksBy :: [Text] -> EitherT ServantErr IO [Book] -- >         getBooksBy authors = ...return all books by these authors...-instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)-      => HasServer (QueryParams sym a :> sublayout) where+instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context m)+      => HasServer (QueryParams sym a :> sublayout) context m where -  type ServerT (QueryParams sym a :> sublayout) m =-    [a] -> ServerT sublayout m+  type ServerT (QueryParams sym a :> sublayout) context m =+    [a] -> ServerT sublayout context m -  route Proxy subserver =+  route Proxy ctx subserver =     let querytext r = parseQueryText $ rqQueryString r         -- if sym is "foo", we look for query string parameters         -- named "foo" or "foo[]" and call parseQueryParam on the         -- corresponding values         parameters r = filter looksLikeParam (querytext r)         values r = mapMaybe (convert . snd) (parameters r)-    in  route (Proxy :: Proxy sublayout) (passToServer subserver values)+    in  route (Proxy :: Proxy sublayout) ctx (passToServer subserver values)     where paramname = cs $ symbolVal (Proxy :: Proxy sym)           looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")           convert Nothing = Nothing@@ -360,19 +368,19 @@ -- > server = getBooks -- >   where getBooks :: Bool -> EitherT ServantErr IO [Book] -- >         getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument...-instance (KnownSymbol sym, HasServer sublayout)-      => HasServer (QueryFlag sym :> sublayout) where+instance (KnownSymbol sym, HasServer sublayout context m)+      => HasServer (QueryFlag sym :> sublayout) context m where -  type ServerT (QueryFlag sym :> sublayout) m =-    Bool -> ServerT sublayout m+  type ServerT (QueryFlag sym :> sublayout) context m =+    Bool -> ServerT sublayout context m -  route Proxy subserver =+  route Proxy ctx subserver =     let querytext r = parseQueryText $ rqQueryString r         param r = case lookup paramname (querytext r) of           Just Nothing  -> True  -- param is there, with no value           Just (Just v) -> examine v -- param with a value           Nothing       -> False -- param not in the query string-    in  route (Proxy :: Proxy sublayout) (passToServer subserver param)+    in  route (Proxy :: Proxy sublayout) ctx (passToServer subserver param)     where paramname = cs $ symbolVal (Proxy :: Proxy sym)           examine v | v == "true" || v == "1" || v == "" = True                     | otherwise = False@@ -386,11 +394,11 @@ -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images"-instance HasServer Raw where+instance HasServer Raw context m where -  type ServerT Raw m = m ()+  type ServerT Raw context m = m () -  route Proxy rawApplication = RawRouter $ \ env request respond -> do+  route Proxy _ rawApplication = RawRouter $ \ env request respond -> do     r <- runDelayed rawApplication env request     case r of       Route app   -> (snapToApplication' app) request (respond . Route)@@ -418,14 +426,14 @@ -- > server = postBook -- >   where postBook :: Book -> EitherT ServantErr IO Book -- >         postBook book = ...insert into your db...-instance ( AllCTUnrender list a, HasServer sublayout-         ) => HasServer (ReqBody list a :> sublayout) where+instance ( AllCTUnrender list a, HasServer sublayout context m+         ) => HasServer (ReqBody list a :> sublayout) context m where -  type ServerT (ReqBody list a :> sublayout) m =-    a -> ServerT sublayout m+  type ServerT (ReqBody list a :> sublayout) context m =+    a -> ServerT sublayout context m -  route Proxy subserver =-    route (Proxy :: Proxy sublayout) (addBodyCheck (subserver ) bodyCheck')+  route Proxy ctx subserver =+    route (Proxy :: Proxy sublayout) ctx (addBodyCheck (subserver ) bodyCheck')     where       -- bodyCheck' :: DelayedM m a       bodyCheck' = do@@ -441,35 +449,55 @@  -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@.-instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where+instance (KnownSymbol path, HasServer sublayout context m) => HasServer (path :> sublayout) context m where -  type ServerT (path :> sublayout) m = ServerT sublayout m+  type ServerT (path :> sublayout) context m = ServerT sublayout context m -  route Proxy subserver =+  route Proxy ctx subserver =     pathRouter       (cs (symbolVal proxyPath))-      (route (Proxy :: Proxy sublayout) subserver)+      (route (Proxy :: Proxy sublayout) ctx subserver)     where proxyPath = Proxy :: Proxy path  -instance HasServer api => HasServer (HttpVersion :> api) where-  type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m+instance HasServer api context m => HasServer (HttpVersion :> api) context m where+  type ServerT (HttpVersion :> api) context m = HttpVersion -> ServerT api context m -  route Proxy subserver =-    route (Proxy :: Proxy api) (passToServer subserver rqVersion)+  route Proxy ctx subserver =+    route (Proxy :: Proxy api) ctx (passToServer subserver rqVersion)  -instance HasServer api => HasServer (IsSecure :> api) where-  type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m+instance HasServer api context m => HasServer (IsSecure :> api) context m where+  type ServerT (IsSecure :> api) context m = IsSecure -> ServerT api context m -  route Proxy subserver =-    route (Proxy :: Proxy api) (passToServer subserver (bool NotSecure Secure . rqIsSecure))+  route Proxy ctx subserver =+    route (Proxy :: Proxy api) ctx (passToServer subserver (bool NotSecure Secure . rqIsSecure)) -instance HasServer api => HasServer (RemoteHost :> api) where-  type ServerT (RemoteHost :> api) m = B.ByteString -> ServerT api m+instance HasServer api context m => HasServer (RemoteHost :> api) context m where+  type ServerT (RemoteHost :> api) context m = B.ByteString -> ServerT api context m -  route Proxy subserver =-    route (Proxy :: Proxy api) (passToServer subserver rqHostName)+  route Proxy ctx subserver =+    route (Proxy :: Proxy api) ctx (passToServer subserver rqHostName)++-- newtype BasicAuthCheck m usr =+--   BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) }+--   deriving (Functor, Generic)++data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr+  deriving (Functor, Eq, Read, Show, Generic)++instance (HasServer api context m,+          KnownSymbol realm,+          HasContextEntry context (BasicAuthCheck m usr)+         ) => HasServer (BasicAuth realm usr :> api) context m where+  type ServerT (BasicAuth realm usr :> api) context m = usr -> ServerT api context m++  route Proxy ctx subserver =+    route (Proxy :: Proxy api) ctx (subserver `addAuthCheck` authCheck)+    where+      realm = B.pack $ symbolVal (Proxy :: Proxy realm)+      basicAuthContext = getContextEntry ctx+      authCheck = withRequest $ \req -> runBasicAuth req realm basicAuthContext  ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP

@@ -0,0 +1,73 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Servant.Server.Internal.BasicAuth where++import           Control.Monad          (guard)+import           Control.Monad.Trans    (liftIO)+import qualified Data.ByteString        as BS+import           Data.ByteString.Base64 (decodeLenient)+import           Data.CaseInsensitive   (CI(..)) +import           Data.Monoid            ((<>))+import           Data.Typeable          (Typeable)+import           Data.Word8             (isSpace, toLower, _colon)+import           GHC.Generics+import           Snap.Core+-- import           Network.HTTP.Types     (Header)+-- import           Network.Wai            (Request, requestHeaders)++import           Servant.API.BasicAuth (BasicAuthData(BasicAuthData))+import           Servant.Server.Internal.RoutingApplication+import           Servant.Server.Internal.ServantErr++-- * Basic Auth++-- | servant-server's current implementation of basic authentication is not+-- immune to certian kinds of timing attacks. Decoding payloads does not take+-- a fixed amount of time.++-- | The result of authentication/authorization+data BasicAuthResult usr+  = Unauthorized+  | BadPassword+  | NoSuchUser+  | Authorized usr+  deriving (Eq, Show, Read, Generic, Typeable, Functor)++-- | Datatype wrapping a function used to check authentication.+newtype BasicAuthCheck m usr = BasicAuthCheck+  { unBasicAuthCheck :: BasicAuthData+                     -> m (BasicAuthResult usr)+  }+  deriving (Generic, Typeable, Functor)++-- | Internal method to make a basic-auth challenge+mkBAChallengerHdr :: BS.ByteString -> (CI BS.ByteString, BS.ByteString)+mkBAChallengerHdr realm = ("WWW-Authenticate", "Basic realm=\"" <> realm <> "\"")++-- | Find and decode an 'Authorization' header from the request as Basic Auth+decodeBAHdr :: Request -> Maybe BasicAuthData+decodeBAHdr req = do+    ah <- getHeader "Authorization" req+    let (b, rest) = BS.break isSpace ah+    guard (BS.map toLower b == "basic")+    let decoded = decodeLenient (BS.dropWhile isSpace rest)+    let (username, passWithColonAtHead) = BS.break (== _colon) decoded+    (_, password) <- BS.uncons passWithColonAtHead+    return (BasicAuthData username password)++-- | Run and check basic authentication, returning the appropriate http error per+-- the spec.+runBasicAuth :: MonadSnap m => Request -> BS.ByteString -> BasicAuthCheck m usr -> DelayedM m usr+runBasicAuth req realm (BasicAuthCheck ba) =+  case decodeBAHdr req of+     Nothing -> plzAuthenticate+     Just e  -> DelayedM (const $ Route <$> ba e) >>= \res -> case res of+       BadPassword    -> plzAuthenticate+       NoSuchUser     -> plzAuthenticate+       Unauthorized   -> delayedFailFatal err403+       Authorized usr -> return usr+  where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }

@@ -0,0 +1,102 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeOperators              #-}++module Servant.Server.Internal.Context where++import           Data.Proxy+import           GHC.TypeLits++-- | 'Context's are used to pass values to combinators. (They are __not__ meant+-- to be used to pass parameters to your handlers, i.e. they should not replace+-- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using+-- with 'Servant.Utils.Enter'.) If you don't use combinators that+-- require any context entries, you can just use 'Servant.Server.serve' as always.+--+-- If you are using combinators that require a non-empty 'Context' you have to+-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all+-- the values your combinators need. A 'Context' is essentially a heterogenous+-- list and accessing the elements is being done by type (see 'getContextEntry').+-- The parameter of the type 'Context' is a type-level list reflecting the types+-- of the contained context entries. To create a 'Context' with entries, use the+-- operator @(':.')@:+--+-- >>> :type True :. () :. EmptyContext+-- True :. () :. EmptyContext :: Context '[Bool, ()]+data Context contextTypes where+    EmptyContext :: Context '[]+    (:.) :: x -> Context xs -> Context (x ': xs)+infixr 5 :.++instance Show (Context '[]) where+  show EmptyContext = "EmptyContext"+instance (Show a, Show (Context as)) => Show (Context (a ': as)) where+  showsPrec outerPrecedence (a :. as) =+    showParen (outerPrecedence > 5) $+      shows a . showString " :. " . shows as++instance Eq (Context '[]) where+    _ == _ = True+instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where+    x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2++-- | This class is used to access context entries in 'Context's. 'getContextEntry'+-- returns the first value where the type matches:+--+-- >>> getContextEntry (True :. False :. EmptyContext) :: Bool+-- True+--+-- If the 'Context' does not contain an entry of the requested type, you'll get+-- an error:+--+-- >>> getContextEntry (True :. False :. EmptyContext) :: String+-- ...+-- ...No instance for (HasContextEntry '[] [Char])+-- ...+class HasContextEntry (context :: [*]) (val :: *) where+    getContextEntry :: Context context -> val++-- TODO OVERLAPPABLE_+instance {-# OVERLAPPABLE #-}+         HasContextEntry xs val => HasContextEntry (notIt ': xs) val where+    getContextEntry (_ :. xs) = getContextEntry xs++instance {-# OVERLAPPABLE #-}+         HasContextEntry (val ': xs) val where+    getContextEntry (x :. _) = x++-- * support for named subcontexts++-- | Normally context entries are accessed by their types. In case you need+-- to have multiple values of the same type in your 'Context' and need to access+-- them, we provide 'NamedContext'. You can think of it as sub-namespaces for+-- 'Context's.+data NamedContext (name :: Symbol) (subContext :: [*])+  = NamedContext (Context subContext)++-- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you+-- won't have to use it yourself but instead use a combinator like+-- 'Servant.API.WithNamedContext.WithNamedContext'.+--+-- This is how 'descendIntoNamedContext' works:+--+-- >>> :set -XFlexibleContexts+-- >>> let subContext = True :. EmptyContext+-- >>> :type subContext+-- subContext :: Context '[Bool]+-- >>> let parentContext = False :. (NamedContext subContext :: NamedContext "subContext" '[Bool]) :. EmptyContext+-- >>> :type parentContext+-- parentContext :: Context '[Bool, NamedContext "subContext" '[Bool]]+-- >>> descendIntoNamedContext (Proxy :: Proxy "subContext") parentContext :: Context '[Bool]+-- True :. EmptyContext+descendIntoNamedContext :: forall context name subContext .+  HasContextEntry context (NamedContext name subContext) =>+  Proxy (name :: Symbol) -> Context context -> Context subContext+descendIntoNamedContext Proxy context =+  let NamedContext subContext = getContextEntry context :: NamedContext name subContext+  in subContext

@@ -34,5 +34,5 @@ -- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory' -- handler in the last position, because /servant/ will try to match the handlers -- in order.-serveDirectory :: MonadSnap m => FilePath -> Server Raw m+serveDirectory :: MonadSnap m => FilePath -> Server Raw context m serveDirectory fp = liftSnap $ Snap.serveDirectory fp