diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.8 +------- + +Copy BasicAuth and Context from servant-server to support basic auth checking + 0.7.1 ------- diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -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 diff --git a/servant-snap.cabal b/servant-snap.cabal --- a/servant-snap.cabal +++ b/servant-snap.cabal @@ -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 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -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 diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -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 diff --git a/src/Servant/Server/Internal/BasicAuth.hs b/src/Servant/Server/Internal/BasicAuth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/BasicAuth.hs @@ -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] } diff --git a/src/Servant/Server/Internal/Context.hs b/src/Servant/Server/Internal/Context.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/Context.hs @@ -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 diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -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