This commit is contained in:
Sönke Hahn 2016-04-12 13:00:39 +08:00
commit b8422e80b2
4 changed files with 14 additions and 5 deletions

View file

@ -44,7 +44,7 @@ You can use this combinator to protect an API as follows:
module Authentication where module Authentication where
import Control.Monad.Trans.Except (ExceptT, throwE) import Control.Monad.Trans.Except (ExceptT)
import Data.Aeson (ToJSON) import Data.Aeson (ToJSON)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Map (Map, fromList) import Data.Map (Map, fromList)
@ -59,6 +59,7 @@ import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
Get, JSON) Get, JSON)
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Experimental.Auth (AuthProtect)
import Servant (throwError)
import Servant.Server (BasicAuthCheck (BasicAuthCheck), import Servant.Server (BasicAuthCheck (BasicAuthCheck),
BasicAuthResult( Authorized BasicAuthResult( Authorized
, Unauthorized , Unauthorized
@ -173,7 +174,7 @@ And now we create the `Context` used by servant to find `BasicAuthCheck`:
```haskell ```haskell
-- | We need to supply our handlers with the right Context. In this case, -- | We need to supply our handlers with the right Context. In this case,
-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value -- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
-- tagged with "foo-tag" This context is then supplied to 'server' and threaded -- tagged with "foo-tag" This context is then supplied to 'server' and threaded
-- to the BasicAuth HasServer handlers. -- to the BasicAuth HasServer handlers.
basicAuthServerContext :: Context (BasicAuthCheck User ': '[]) basicAuthServerContext :: Context (BasicAuthCheck User ': '[])
basicAuthServerContext = authCheck :. EmptyContext basicAuthServerContext = authCheck :. EmptyContext
@ -274,7 +275,7 @@ database = fromList [ ("key1", Account "Anne Briggs")
-- This is our bespoke (and bad) authentication logic. -- This is our bespoke (and bad) authentication logic.
lookupAccount :: ByteString -> ExceptT ServantErr IO Account lookupAccount :: ByteString -> ExceptT ServantErr IO Account
lookupAccount key = case Map.lookup key database of lookupAccount key = case Map.lookup key database of
Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) Nothing -> throwError (err403 { errBody = "Invalid Cookie" })
Just usr -> return usr Just usr -> return usr
``` ```
@ -289,7 +290,7 @@ method:
authHandler :: AuthHandler Request Account authHandler :: AuthHandler Request Account
authHandler = authHandler =
let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
Nothing -> throwE (err401 { errBody = "Missing auth header" }) Nothing -> throwError (err401 { errBody = "Missing auth header" })
Just authCookieKey -> lookupAccount authCookieKey Just authCookieKey -> lookupAccount authCookieKey
in mkAuthHandler handler in mkAuthHandler handler
``` ```
@ -329,7 +330,7 @@ We now construct the `Context` for our server, allowing us to instantiate a
value of type `Server AuthGenAPI`, in addition to the server value: value of type `Server AuthGenAPI`, in addition to the server value:
```haskell ```haskell
-- | The context that will be made available to request handlers. We supply the -- | 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 -- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
-- of 'AuthProtect' can extract the handler and run it on the request. -- of 'AuthProtect' can extract the handler and run it on the request.
genAuthServerContext :: Context (AuthHandler Request Account ': '[]) genAuthServerContext :: Context (AuthHandler Request Account ': '[])

View file

@ -1,3 +1,8 @@
HEAD
----
* Use `throwError` instead of `throwE` in documentation
0.5 0.5
---- ----

View file

@ -6,6 +6,7 @@
to the correct endpoint. Functions `layout` and `layoutWithContext` have to the correct endpoint. Functions `layout` and `layoutWithContext` have
been added to visualize the router layout for debugging purposes. Test been added to visualize the router layout for debugging purposes. Test
cases for expected router layouts have been added. cases for expected router layouts have been added.
* Export `throwError` from module `Servant`
0.6.1 0.6.1
----- -----

View file

@ -10,8 +10,10 @@ module Servant (
module Servant.Utils.StaticFiles, module Servant.Utils.StaticFiles,
-- | Useful re-exports -- | Useful re-exports
Proxy(..), Proxy(..),
throwError
) where ) where
import Control.Monad.Error.Class (throwError)
import Data.Proxy import Data.Proxy
import Servant.API import Servant.API
import Servant.Server import Servant.Server