@@ -44,26 +44,33 @@ You can use this combinator to protect an API as follows:
45module Authentication where
45module Authentication where
47+import Control.Monad.Trans.Except (ExceptT, throwE)
47import Data.Aeson (ToJSON)
48import Data.Aeson (ToJSON)
49+import Data.ByteString (ByteString)
50+import Data.Map (Map, fromList)
51+import Data.Monoid ((<>))
52+import qualified Data.Map as Map
48import Data.Proxy (Proxy (Proxy))
53import Data.Proxy (Proxy (Proxy))
49import Data.Text (Text)
54import Data.Text (Text)
50import GHC.Generics (Generic)
55import GHC.Generics (Generic)
56+import Network.Wai (Request, requestHeaders)
51import Network.Wai.Handler.Warp (run)
57import Network.Wai.Handler.Warp (run)
52import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
58import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
53 Get, JSON)
59 Get, JSON)
54import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
60import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
55−import Servant.API.Experimental (AuthProtect)
61+import Servant.API.Experimental.Auth (AuthProtect)
56import Servant.Server (BasicAuthCheck (BasicAuthCheck),
62import Servant.Server (BasicAuthCheck (BasicAuthCheck),
57 BasicAuthResult( Authorized
63 BasicAuthResult( Authorized
58 , Unauthorized
64 , Unauthorized
60− Context ((:.), EmptyContext), Server,
66+ Context ((:.), EmptyContext),
67+ err401, err403, errBody, Server,
61− serveWithContext)
68+ ServantErr, serveWithContext)
62import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
69import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
63 mkAuthHandler)
70 mkAuthHandler)
64−import Servant.Server.Experimenta.Auth()
71+import Servant.Server.Experimental.Auth()
66−- | private data that needs protection
73+-- | private data that needs protection
67newtype PrivateData = PrivateData { ssshhh :: Text }
74newtype PrivateData = PrivateData { ssshhh :: Text }
68 deriving (Eq, Show, Generic)
75 deriving (Eq, Show, Generic)
@@ -168,8 +175,8 @@ And now we create the `Context` used by servant to find `BasicAuthCheck`:
168-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
175-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
169-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
176-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
170-- to the BasicAuth HasServer handlers.
177-- to the BasicAuth HasServer handlers.
171−serverContext :: Context (BasicAuthCheck User ': '[])
178+basicAuthServerContext :: Context (BasicAuthCheck User ': '[])
172−serverContext = authCheck :. EmptyContext
179+basicAuthServerContext = authCheck :. EmptyContext
175We're now ready to write our `server` method that will tie everything together:
182We're now ready to write our `server` method that will tie everything together:
@@ -178,8 +185,8 @@ We're now ready to write our `server` method that will tie everything together:
178-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.
185-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.
179-- In particular, for the BasicAuth protected handler, we need to supply a function
186-- In particular, for the BasicAuth protected handler, we need to supply a function
180-- that takes 'User' as an argument.
187-- that takes 'User' as an argument.
181−server :: Server BasicAPI
188+basicAuthServer :: Server BasicAPI
182−server =
189+basicAuthServer =
183 let publicAPIHandler = return [PublicData "foo", PublicData "bar"]
190 let publicAPIHandler = return [PublicData "foo", PublicData "bar"]
184 privateAPIHandler (user :: User) = return (PrivateData (userName user))
191 privateAPIHandler (user :: User) = return (PrivateData (userName user))
185 in publicAPIHandler :<|> privateAPIHandler
192 in publicAPIHandler :<|> privateAPIHandler
@@ -190,7 +197,10 @@ Finally, our main method and a sample session working with our server:
190```haskell
197```haskell
191-- | hello, server!
198-- | hello, server!
192basicAuthMain :: IO ()
199basicAuthMain :: IO ()
193−basicAuthMain = run 8080 (serveWithContext basicAuthApi serverContext server)
200+basicAuthMain = run 8080 (serveWithContext basicAuthApi
201+ basicAuthServerContext
195{- Sample session
205{- Sample session
@@ -251,36 +261,36 @@ contain a key from which we can lookup a `User`.
251```haskell
261```haskell
252-- | A user type that we "fetch from the database" after
262-- | A user type that we "fetch from the database" after
253-- performing authentication
263-- performing authentication
254−newtype User = User { unUser :: Text }
264+newtype Account = Account { unAccount :: Text }
256-- | A (pure) database mapping keys to users.
266-- | A (pure) database mapping keys to users.
257−database :: Map ByteString User
267+database :: Map ByteString Account
258−database = fromList [ ("key1", User "Anne Briggs")
268+database = fromList [ ("key1", Account "Anne Briggs")
259− , ("key2", User "Bruce Cockburn")
269+ , ("key2", Account "Bruce Cockburn")
260− , ("key3", User "Ghédalia Tazartès")
270+ , ("key3", Account "Ghédalia Tazartès")
263−-- | A method that, when given a password, will return a User.
273+-- | A method that, when given a password, will return a Account.
264-- This is our bespoke (and bad) authentication logic.
274-- This is our bespoke (and bad) authentication logic.
265−lookupUser :: ByteString -> ExceptT ServantErr IO User
275+lookupAccount :: ByteString -> ExceptT ServantErr IO Account
266−lookupUser key = case Map.lookup key database of
276+lookupAccount key = case Map.lookup key database of
267 Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
277 Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
268 Just usr -> return usr
278 Just usr -> return usr
271For generalized authentication, servant exposes the `AuthHandler` type,
281For generalized authentication, servant exposes the `AuthHandler` type,
272which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's
282which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's
273−create a value of type `AuthHandler Request User` using the above `lookupUser`
283+create a value of type `AuthHandler Request Account` using the above `lookupAccount`
276```haskell
286```haskell
277−-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
287+-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO Account
278−-- we look for a Cookie and pass the value of the cookie to `lookupUser`.
288+-- we look for a Cookie and pass the value of the cookie to `lookupAccount`.
279−authHandler :: AuthHandler Request User
289+authHandler :: AuthHandler Request Account
280authHandler =
290authHandler =
281 let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
291 let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
282 Nothing -> throwE (err401 { errBody = "Missing auth header" })
292 Nothing -> throwE (err401 { errBody = "Missing auth header" })
283− Just authCookieKey -> lookupUser authCookieKey
293+ Just authCookieKey -> lookupAccount authCookieKey
284 in mkAuthHandler handler
294 in mkAuthHandler handler
@@ -293,22 +303,22 @@ type AuthGenAPI = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
293 :<|> "public" :> PublicAPI
303 :<|> "public" :> PublicAPI
295-- | A value holding our type-level API
305-- | A value holding our type-level API
296−genAuthApi :: Proxy AuthGenAPI
306+genAuthAPI :: Proxy AuthGenAPI
297−genAuthApi = Proxy
307+genAuthAPI = Proxy
300Now we need to bring everything together for the server. We have the
310Now we need to bring everything together for the server. We have the
301−`AuthHandler Request User` value and an `AuthProtected` endpoint. To bind these
311+`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these
302together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html)
312together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html)
303instance that tells the `HasServer` instance that our `Context` will supply a
313instance that tells the `HasServer` instance that our `Context` will supply a
304−`User` (via `AuthHandler Request User`) and that downstream combinators will
314+`Account` (via `AuthHandler Request Account`) and that downstream combinators will
305−have access to this `User` value (or an error will be thrown if authentication
315+have access to this `Account` value (or an error will be thrown if authentication
308```haskell
318```haskell
310-- | We need to specify the data returned after authentication
320-- | We need to specify the data returned after authentication
311−type instance AuthServerData (AuthProtect "cookie-auth") = User
321+type instance AuthServerData (AuthProtect "cookie-auth") = Account
314Note that we specify the type-level tag `"cookie-auth"` when defining the type
324Note that we specify the type-level tag `"cookie-auth"` when defining the type
@@ -322,19 +332,19 @@ value of type `Server AuthGenAPI`, in addition to the server value:
322-- | The context that will be made available to request handlers. We supply the
332-- | The context that will be made available to request handlers. We supply the
323-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
333-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
324-- of 'AuthProtect' can extract the handler and run it on the request.
334-- of 'AuthProtect' can extract the handler and run it on the request.
325−serverContext :: Context (AuthHandler Request User ': '[])
335+genAuthServerContext :: Context (AuthHandler Request Account ': '[])
326−serverContext = authHandler :. EmptyContext
336+genAuthServerContext = authHandler :. EmptyContext
328-- | Our API, where we provide all the author-supplied handlers for each end
338-- | Our API, where we provide all the author-supplied handlers for each end
329−-- point. Note that 'privateDataFunc' is a function that takes 'User' as an
339+-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an
330-- argument. We dont' worry about the authentication instrumentation here,
340-- argument. We dont' worry about the authentication instrumentation here,
331-- that is taken care of by supplying context
341-- that is taken care of by supplying context
332−server :: Server AuthGenAPI
342+genAuthServer :: Server AuthGenAPI
333−server =
343+genAuthServer =
334− let privateDataFunc (User name) =
344+ let privateDataFunc (Account name) =
335− return [PrivateData ("this is a secret: " <> name)]
345+ return (PrivateData ("this is a secret: " <> name))
336− publicData = [PublicData "this is a public piece of data"]
346+ publicData = return [PublicData "this is a public piece of data"]
337− in privateDataFunc :<|> return publicData
347+ in privateDataFunc :<|> publicData
340We're now ready to start our server (and provide a sample session)!
350We're now ready to start our server (and provide a sample session)!
@@ -342,7 +352,7 @@ We're now ready to start our server (and provide a sample session)!
342```haskell
352```haskell
343-- | run our server
353-- | run our server
344genAuthMain :: IO ()
354genAuthMain :: IO ()
345−genAuthMain = run 8080 (serveWithContext api serverContext server)
355+genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuthServer)
347{- Sample Session:
357{- Sample Session: