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