@@ -9,56 +9,53 @@
9{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
12+import Control.Monad.Trans.Except (ExceptT, throwE)
12−import Data.Aeson
13+import Data.Aeson hiding ((.:))
13−import Data.ByteString (ByteString)
14+import Data.ByteString (ByteString)
14−import Data.IORef
15+import Data.Monoid ((<>))
15−import Data.Text (Text)
16+import Data.Map (Map, fromList)
17+import qualified Data.Map as Map
18+import Data.Text (Text)
16import GHC.Generics
19import GHC.Generics
17import Network.Wai
20import Network.Wai
18import Network.Wai.Handler.Warp
21import Network.Wai.Handler.Warp
19import Servant
22import Servant
20−import Servant.Server.Internal
22−-- Pretty much stolen/adapted from
23−-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
25−type DBConnection = IORef [ByteString]
26−type DBLookup = DBConnection -> ByteString -> IO Bool
28−initDB :: IO DBConnection
29−initDB = newIORef ["good password"]
31−isGoodCookie :: DBLookup
32−isGoodCookie ref password = do
33− allowed <- readIORef ref
34− return (password `elem` allowed)
38−instance (HasContextEntry context DBConnection, HasServer rest context)
39− => HasServer (AuthProtected :> rest) context where
41− type ServerT (AuthProtected :> rest) m = ServerT rest m
43− route Proxy context subserver = WithRequest $ \ request ->
44− route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request
46− cookieCheck req = case lookup "Cookie" (requestHeaders req) of
47− Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
49− let dbConnection = getContextEntry context
50− authGranted <- isGoodCookie dbConnection v
52− then return $ Route ()
53− else return $ FailFatal err403 { errBody = "Invalid cookie" }
55−type PrivateAPI = Get '[JSON] [PrivateData]
57−type PublicAPI = Get '[JSON] [PublicData]
59−type API = "private" :> AuthProtected :> PrivateAPI
24+-- | This file contains an authenticated server using servant's generalized
25+-- authentication support. Our basic authentication scheme is trivial: we
26+-- look for a cookie named "servant-auth-cookie" and its value will contain
27+-- a key, which we use to lookup a User. Obviously this is an absurd example,
28+-- but we pick something simple and non-standard to show you how to extend
29+-- servant's support for authentication.
31+-- | A user type that we "fetch from the database" after
32+-- performing authentication
33+newtype User = User { unUser :: Text }
35+-- | A (pure) database mapping keys to users.
36+database :: Map ByteString User
37+database = fromList [ ("key1", User "Anne Briggs")
38+ , ("key2", User "Bruce Cockburn")
39+ , ("key3", User "Ghédalia Tazartès")
42+-- | A method that, when given a password, will return a User.
43+-- This is our bespoke (and bad) authentication logic.
44+lookupUser :: ByteString -> ExceptT ServantErr IO User
45+lookupUser key = case Map.lookup key database of
46+ Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
47+ Just usr -> return usr
49+-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
50+-- we look for a Cookie and pass the value of the cookie to `lookupUser`.
51+authHandler :: AuthHandler Request User
53+ let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
54+ Nothing -> throwE (err401 { errBody = "Missing auth header" })
55+ Just authCookieKey -> lookupUser authCookieKey
56+ in mkAuthHandler handler
58+-- | Data types that will be returned from various api endpoints
62newtype PrivateData = PrivateData { ssshhh :: Text }
59newtype PrivateData = PrivateData { ssshhh :: Text }
63 deriving (Eq, Show, Generic)
60 deriving (Eq, Show, Generic)
@@ -69,28 +66,58 @@ newtype PublicData = PublicData { somedata :: Text }
70instance ToJSON PublicData
67instance ToJSON PublicData
69+-- | Our private API that we want to be auth-protected.
70+type PrivateAPI = Get '[JSON] [PrivateData]
72+-- | Our public API that doesn't have any protection
73+type PublicAPI = Get '[JSON] [PublicData]
75+-- | Our API, with auth-protection
76+type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
77+ :<|> "public" :> PublicAPI
79+-- | A value holding our type-level API
72api :: Proxy API
80api :: Proxy API
73api = Proxy
81api = Proxy
83+-- | We need to specify the data returned after authentication
84+type instance AuthServerData (AuthProtect "cookie-auth") = User
86+-- | The context that will be made available to request handlers. We supply the
87+-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
88+-- of 'AuthProtect' can extract the handler and run it on the request.
89+serverContext :: Context (AuthHandler Request User ': '[])
90+serverContext = authHandler :. EmptyContext
92+-- | Our API, where we provide all the author-supplied handlers for each end
93+-- point. Note that 'privateDataFunc' is a function that takes 'User' as an
94+-- argument. We dont' worry about the authentication instrumentation here,
95+-- that is taken care of by supplying context
75server :: Server API
96server :: Server API
76−server = return prvdata :<|> return pubdata
97+server = privateDataFunc :<|> return publicData
99+ where privateDataFunc (User name) =
78− where prvdata = [PrivateData "this is a secret"]
100+ return [PrivateData ("this is a secret: " <> name)]
79− pubdata = [PublicData "this is a public piece of data"]
101+ publicData = [PublicData "this is a public piece of data"]
81main :: IO ()
104main :: IO ()
83− dbConnection <- initDB
84− let context = dbConnection :. EmptyContext
85− run 8080 (serveWithContext api context server)
105+main = run 8080 (serveWithContext api serverContext server)
109+$ curl -XGET localhost:8080/private
111+>>>>>>> modify auth-combinator example for gen auth
112+>>>>>>> 8246c1f... modify auth-combinator example for gen auth
87−{- Sample session:
114+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
115+[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
117+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
88−$ curl http://localhost:8080/
120+$ curl -XGET localhost:8080/public
89[{"somedata":"this is a public piece of data"}]
121[{"somedata":"this is a public piece of data"}]
90−$ curl http://localhost:8080/private
92−$ curl -H "Cookie: good password" http://localhost:8080/private
93−[{"ssshhh":"this is a secret"}]
94−$ curl -H "Cookie: bad password" http://localhost:8080/private