diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index b48c0480..4d3e455d 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -7,60 +7,69 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} import Data.Aeson import Data.ByteString (ByteString) -import Data.ByteString.Builder.Internal (byteStringCopy) +import qualified Data.ByteString as B import Data.Monoid ((<>)) import Data.Text (Text) import GHC.Generics -import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp import Servant import Servant.API.Authentication -import Servant.Server.Internal -import Servant.Server.Internal.Authentication (strictProtect, AuthHandlers(AuthHandlers)) -- | Data we will use to test for authentication data CookieAuth = CookieAuth { cookie :: ByteString } +-- | An ADT to index errors we may encounter when retrieving a cookie from a request +data CookieFromRequestError = CookieNotPresent + | CookieInvalid + -- | A 'User' datatype we get once the authentication data is tested. type User = ByteString +-- | An ADT to index errors we may encounter when retrieving a user from the database +-- based on the cookie +data UserFromCookieError = NoUserAssociatedWithCookie + | MoreThanOneCookieInDatabase Int + -- | We will look up authentication data in the database and extract a User. -type DBLookup = CookieAuth -> IO (Maybe User) +type DBLookup = CookieAuth -> IO (Either UserFromCookieError User) -- | Method that tests for authentication and extracts a User type. -isGoodCookie :: DBLookup -isGoodCookie (CookieAuth cookie) = if cookie == "good cookie" then return (Just "one user") else return Nothing +userFromCookie :: DBLookup +userFromCookie (CookieAuth cookie) = if cookie == "good cookie" then return (Right "one user") else return (Left NoUserAssociatedWithCookie) --- | Response handlers: what do we do when authentication doesn't work. -cookieAuthHandlers :: AuthHandlers CookieAuth -cookieAuthHandlers = AuthHandlers missingAuth notAuthenticated - where - missingAuth :: IO Response - missingAuth = return $ (responseBuilder status401 [] "Missing Cookie header.") +-- | a handler that takes a cookie error and returns a ServantErr in IO +missingCookieHandler :: OnMissing IO ServantErr 'Strict CookieFromRequestError +missingCookieHandler = + let handler error = case error of + CookieNotPresent -> return $ err401 { errReasonPhrase = "No cookie" } + CookieInvalid -> return (err401 { errReasonPhrase = "Invalid Cookie" }) + in StrictMissing handler - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request - where - cookieCheck req = case lookup "Cookie" (requestHeaders req) of - Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" } - Just v -> do - authGranted <- isGoodCookie v - if authGranted - then return $ Route () - else return $ FailFatal err403 { errBody = "Invalid cookie" } - - notAuthenticated :: CookieAuth -> IO Response - notAuthenticated (CookieAuth cookie) = return $ - responseBuilder status401 [] ("Invalid cookie: " <> byteStringCopy cookie) +-- | a handler that takes a Cookie + extraction error and returns a IO ServantErr. +-- This handler is called when a valid authentication data (e.g. Cookie) was extracted +-- from the request, but we were not able to find a valid user in our database. +unauthenticatedHandler :: OnUnauthenticated IO ServantErr 'Strict UserFromCookieError CookieAuth +unauthenticatedHandler = + let handler error _ = case error of + NoUserAssociatedWithCookie -> + return (err403 { errReasonPhrase = "you don't exist" }) + (MoreThanOneCookieInDatabase i) -> + return (err403 { errReasonPhrase = "we found " <> show i <> " of you. WAT?" }) + in StrictUnauthenticated handler -- | 'AuthData' is a typeclass that provides a method to extract authentication --- data from a 'Request' -instance AuthData CookieAuth where - authData req = fmap CookieAuth (lookup "Cookie" (requestHeaders req)) +-- data from a 'Request'. +instance AuthData CookieAuth CookieFromRequestError where + authData req = case lookup "Cookie" (requestHeaders req) of + Nothing -> Left CookieNotPresent + (Just cookieVal) -> if B.length cookieVal > 10 + then Left CookieInvalid + else Right (CookieAuth cookieVal) -- | Some data we will return from our API that is protected newtype PrivateData = PrivateData { ssshhh :: Text } @@ -80,15 +89,21 @@ type PrivateAPI = Get '[JSON] [PrivateData] -- | Public API (non-authenticated) as a type type PublicAPI = Get '[JSON] [PublicData] +-- | A type alias for our auth protection +type CookieAuthProtected = AuthProtect CookieAuth User 'Strict CookieFromRequestError 'Strict UserFromCookieError + -- | Our full API as a type with authentication -type API = AuthProtect CookieAuth User 'Strict :> "private" :> PrivateAPI +type API = CookieAuthProtected :> "private" :> PrivateAPI :<|> PublicAPI api :: Proxy API api = Proxy server :: Server API -server = strictProtect isGoodCookie cookieAuthHandlers (const (return prvdata)) +server = authProtect missingCookieHandler + unauthenticatedHandler + userFromCookie + (\_ -> return prvdata) :<|> return pubdata where prvdata = [PrivateData "this is a secret"]