@@ -9,56 +9,53 @@
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
6123
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.
30+
31+-- | A user type that we "fetch from the database" after
32+-- performing authentication
33+newtype User = User { unUser :: Text }
34+
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")
40+ ]
41+
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
48+
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
52+authHandler =
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
57+
58+-- | Data types that will be returned from various api endpoints
6259newtype PrivateData = PrivateData { ssshhh :: Text }
6360 deriving (Eq, Show, Generic)
6461
@@ -69,28 +66,58 @@ newtype PublicData = PublicData { somedata :: Text }
6966
7067instance ToJSON PublicData
7168
69+-- | Our private API that we want to be auth-protected.
70+type PrivateAPI = Get '[JSON] [PrivateData]
71+
72+-- | Our public API that doesn't have any protection
73+type PublicAPI = Get '[JSON] [PublicData]
74+
75+-- | Our API, with auth-protection
76+type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
77+ :<|> "public" :> PublicAPI
78+
79+-- | A value holding our type-level API
7280api :: Proxy API
7381api = Proxy
7482
83+-- | We need to specify the data returned after authentication
84+type instance AuthServerData (AuthProtect "cookie-auth") = User
85+
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
91+
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
7596server :: Server API
76−server = return prvdata :<|> return pubdata
97+server = privateDataFunc :<|> return publicData
7798
78− where prvdata = [PrivateData "this is a secret"]
79− pubdata = [PublicData "this is a public piece of data"]
99+ where privateDataFunc (User name) =
100+ return [PrivateData ("this is a secret: " <> name)]
101+ publicData = [PublicData "this is a public piece of data"]
80102
103+-- | run our server
81104main :: IO ()
82−main = do
83− dbConnection <- initDB
84− let context = dbConnection :. EmptyContext
85− run 8080 (serveWithContext api context server)
105+main = run 8080 (serveWithContext api serverContext server)
106+
107+{- Sample Session:
108+
109+$ curl -XGET localhost:8080/private
110+Missing auth header
111+>>>>>>> modify auth-combinator example for gen auth
112+>>>>>>> 8246c1f... modify auth-combinator example for gen auth
86113
87−{- Sample session:
88−$ curl http://localhost:8080/
114+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
115+[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
116+
117+$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
118+Invalid Cookie
119+
120+$ curl -XGET localhost:8080/public
89121[{"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.
96122-}
123+