diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index 94bb8931..bfa4b6ee 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -9,56 +9,53 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -import Data.Aeson -import Data.ByteString (ByteString) -import Data.IORef -import Data.Text (Text) +import Control.Monad.Trans.Except (ExceptT, throwE) +import Data.Aeson hiding ((.:)) +import Data.ByteString (ByteString) +import Data.Monoid ((<>)) +import Data.Map (Map, fromList) +import qualified Data.Map as Map +import Data.Text (Text) import GHC.Generics import Network.Wai import Network.Wai.Handler.Warp import Servant -import Servant.Server.Internal --- Pretty much stolen/adapted from --- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs +-- | This file contains an authenticated server using servant's generalized +-- authentication support. Our basic authentication scheme is trivial: we +-- look for a cookie named "servant-auth-cookie" and its value will contain +-- a key, which we use to lookup a User. Obviously this is an absurd example, +-- but we pick something simple and non-standard to show you how to extend +-- servant's support for authentication. -type DBConnection = IORef [ByteString] -type DBLookup = DBConnection -> ByteString -> IO Bool +-- | A user type that we "fetch from the database" after +-- performing authentication +newtype User = User { unUser :: Text } -initDB :: IO DBConnection -initDB = newIORef ["good password"] +-- | A (pure) database mapping keys to users. +database :: Map ByteString User +database = fromList [ ("key1", User "Anne Briggs") + , ("key2", User "Bruce Cockburn") + , ("key3", User "Ghédalia Tazartès") + ] -isGoodCookie :: DBLookup -isGoodCookie ref password = do - allowed <- readIORef ref - return (password `elem` allowed) +-- | A method that, when given a password, will return a User. +-- This is our bespoke (and bad) authentication logic. +lookupUser :: ByteString -> ExceptT ServantErr IO User +lookupUser key = case Map.lookup key database of + Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) + Just usr -> return usr -data AuthProtected - -instance (HasContextEntry context DBConnection, HasServer rest context) - => HasServer (AuthProtected :> rest) context where - - type ServerT (AuthProtected :> rest) m = ServerT rest m - - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request - where - cookieCheck req = case lookup "Cookie" (requestHeaders req) of - Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" } - Just v -> do - let dbConnection = getContextEntry context - authGranted <- isGoodCookie dbConnection v - if authGranted - then return $ Route () - else return $ FailFatal err403 { errBody = "Invalid cookie" } - -type PrivateAPI = Get '[JSON] [PrivateData] - -type PublicAPI = Get '[JSON] [PublicData] - -type API = "private" :> AuthProtected :> PrivateAPI - :<|> PublicAPI +-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User +-- we look for a Cookie and pass the value of the cookie to `lookupUser`. +authHandler :: AuthHandler Request User +authHandler = + let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of + Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Just authCookieKey -> lookupUser authCookieKey + in mkAuthHandler handler +-- | Data types that will be returned from various api endpoints newtype PrivateData = PrivateData { ssshhh :: Text } deriving (Eq, Show, Generic) @@ -69,28 +66,58 @@ newtype PublicData = PublicData { somedata :: Text } instance ToJSON PublicData +-- | Our private API that we want to be auth-protected. +type PrivateAPI = Get '[JSON] [PrivateData] + +-- | Our public API that doesn't have any protection +type PublicAPI = Get '[JSON] [PublicData] + +-- | Our API, with auth-protection +type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI + :<|> "public" :> PublicAPI + +-- | A value holding our type-level API api :: Proxy API api = Proxy +-- | We need to specify the data returned after authentication +type instance AuthServerData (AuthProtect "cookie-auth") = User + +-- | The context that will be made available to request handlers. We supply the +-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance +-- of 'AuthProtect' can extract the handler and run it on the request. +serverContext :: Context (AuthHandler Request User ': '[]) +serverContext = authHandler :. EmptyContext + +-- | Our API, where we provide all the author-supplied handlers for each end +-- point. Note that 'privateDataFunc' is a function that takes 'User' as an +-- argument. We dont' worry about the authentication instrumentation here, +-- that is taken care of by supplying context server :: Server API -server = return prvdata :<|> return pubdata +server = privateDataFunc :<|> return publicData - where prvdata = [PrivateData "this is a secret"] - pubdata = [PublicData "this is a public piece of data"] + where privateDataFunc (User name) = + return [PrivateData ("this is a secret: " <> name)] + publicData = [PublicData "this is a public piece of data"] +-- | run our server main :: IO () -main = do - dbConnection <- initDB - let context = dbConnection :. EmptyContext - run 8080 (serveWithContext api context server) +main = run 8080 (serveWithContext api serverContext server) -{- Sample session: -$ curl http://localhost:8080/ +{- Sample Session: + +$ curl -XGET localhost:8080/private +Missing auth header +>>>>>>> modify auth-combinator example for gen auth +>>>>>>> 8246c1f... modify auth-combinator example for gen auth + +$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3" +[{"ssshhh":"this is a secret: Ghédalia Tazartès"}] + +$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key" +Invalid Cookie + +$ curl -XGET localhost:8080/public [{"somedata":"this is a public piece of data"}] -$ curl http://localhost:8080/private -Missing auth header. -$ curl -H "Cookie: good password" http://localhost:8080/private -[{"ssshhh":"this is a secret"}] -$ curl -H "Cookie: bad password" http://localhost:8080/private -Invalid cookie. -} + diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index a36a5eba..1f00349e 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -112,10 +112,12 @@ executable auth-combinator aeson >= 0.8 , base >= 4.7 && < 5 , bytestring + , containers , http-types , servant == 0.5.* , servant-server == 0.5.* , text + , transformers , wai , warp hs-source-dirs: auth-combinator