Merge pull request #429 from haskell-servant/add-auth-to-tutorial-toc

include Authentication.lhs in tutorial project and table of contents
This commit is contained in:
Aaron Levin 2016-03-26 22:57:51 +01:00
commit 57afd80d5d
3 changed files with 52 additions and 39 deletions

View file

@ -44,26 +44,33 @@ 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 Data.Aeson (ToJSON) import Data.Aeson (ToJSON)
import Data.ByteString (ByteString)
import Data.Map (Map, fromList)
import Data.Monoid ((<>))
import qualified Data.Map as Map
import Data.Proxy (Proxy (Proxy)) import Data.Proxy (Proxy (Proxy))
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.Wai (Request, requestHeaders)
import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.Warp (run)
import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth, import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
Get, JSON) Get, JSON)
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
import Servant.API.Experimental (AuthProtect) import Servant.API.Experimental.Auth (AuthProtect)
import Servant.Server (BasicAuthCheck (BasicAuthCheck), import Servant.Server (BasicAuthCheck (BasicAuthCheck),
BasicAuthResult( Authorized BasicAuthResult( Authorized
, Unauthorized , Unauthorized
), ),
Context ((:.), EmptyContext), Server, Context ((:.), EmptyContext),
serveWithContext) err401, err403, errBody, Server,
ServantErr, serveWithContext)
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
mkAuthHandler) mkAuthHandler)
import Servant.Server.Experimenta.Auth() import Servant.Server.Experimental.Auth()
- | private data that needs protection -- | private data that needs protection
newtype PrivateData = PrivateData { ssshhh :: Text } newtype PrivateData = PrivateData { ssshhh :: Text }
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
@ -168,8 +175,8 @@ And now we create the `Context` used by servant to find `BasicAuthCheck`:
-- 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.
serverContext :: Context (BasicAuthCheck User ': '[]) basicAuthServerContext :: Context (BasicAuthCheck User ': '[])
serverContext = authCheck :. EmptyContext basicAuthServerContext = authCheck :. EmptyContext
``` ```
We're now ready to write our `server` method that will tie everything together: We'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:
-- | an implementation of our server. Here is where we pass all the handlers to our endpoints. -- | an implementation of our server. Here is where we pass all the handlers to our endpoints.
-- In particular, for the BasicAuth protected handler, we need to supply a function -- In particular, for the BasicAuth protected handler, we need to supply a function
-- that takes 'User' as an argument. -- that takes 'User' as an argument.
server :: Server BasicAPI basicAuthServer :: Server BasicAPI
server = basicAuthServer =
let publicAPIHandler = return [PublicData "foo", PublicData "bar"] let publicAPIHandler = return [PublicData "foo", PublicData "bar"]
privateAPIHandler (user :: User) = return (PrivateData (userName user)) privateAPIHandler (user :: User) = return (PrivateData (userName user))
in publicAPIHandler :<|> privateAPIHandler in publicAPIHandler :<|> privateAPIHandler
@ -190,7 +197,10 @@ Finally, our main method and a sample session working with our server:
```haskell ```haskell
-- | hello, server! -- | hello, server!
basicAuthMain :: IO () basicAuthMain :: IO ()
basicAuthMain = run 8080 (serveWithContext basicAuthApi serverContext server) basicAuthMain = run 8080 (serveWithContext basicAuthApi
basicAuthServerContext
basicAuthServer
)
{- Sample session {- Sample session
@ -251,36 +261,36 @@ contain a key from which we can lookup a `User`.
```haskell ```haskell
-- | A user type that we "fetch from the database" after -- | A user type that we "fetch from the database" after
-- performing authentication -- performing authentication
newtype User = User { unUser :: Text } newtype Account = Account { unAccount :: Text }
-- | A (pure) database mapping keys to users. -- | A (pure) database mapping keys to users.
database :: Map ByteString User database :: Map ByteString Account
database = fromList [ ("key1", User "Anne Briggs") database = fromList [ ("key1", Account "Anne Briggs")
, ("key2", User "Bruce Cockburn") , ("key2", Account "Bruce Cockburn")
, ("key3", User "Ghédalia Tazartès") , ("key3", Account "Ghédalia Tazartès")
] ]
-- | A method that, when given a password, will return a User. -- | A method that, when given a password, will return a Account.
-- This is our bespoke (and bad) authentication logic. -- This is our bespoke (and bad) authentication logic.
lookupUser :: ByteString -> ExceptT ServantErr IO User lookupAccount :: ByteString -> ExceptT ServantErr IO Account
lookupUser key = case Map.lookup key database of lookupAccount key = case Map.lookup key database of
Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
Just usr -> return usr Just usr -> return usr
``` ```
For generalized authentication, servant exposes the `AuthHandler` type, For generalized authentication, servant exposes the `AuthHandler` type,
which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's
create a value of type `AuthHandler Request User` using the above `lookupUser` create a value of type `AuthHandler Request Account` using the above `lookupAccount`
method: method:
```haskell ```haskell
-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User -- | The auth handler wraps a function from Request -> ExceptT ServantErr IO Account
-- we look for a Cookie and pass the value of the cookie to `lookupUser`. -- we look for a Cookie and pass the value of the cookie to `lookupAccount`.
authHandler :: AuthHandler Request User 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 -> throwE (err401 { errBody = "Missing auth header" })
Just authCookieKey -> lookupUser authCookieKey Just authCookieKey -> lookupAccount authCookieKey
in mkAuthHandler handler in mkAuthHandler handler
``` ```
@ -293,22 +303,22 @@ type AuthGenAPI = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
:<|> "public" :> PublicAPI :<|> "public" :> PublicAPI
-- | A value holding our type-level API -- | A value holding our type-level API
genAuthApi :: Proxy AuthGenAPI genAuthAPI :: Proxy AuthGenAPI
genAuthApi = Proxy genAuthAPI = Proxy
``` ```
Now we need to bring everything together for the server. We have the Now we need to bring everything together for the server. We have the
`AuthHandler Request User` value and an `AuthProtected` endpoint. To bind these `AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these
together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html) together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html)
instance that tells the `HasServer` instance that our `Context` will supply a instance that tells the `HasServer` instance that our `Context` will supply a
`User` (via `AuthHandler Request User`) and that downstream combinators will `Account` (via `AuthHandler Request Account`) and that downstream combinators will
have access to this `User` value (or an error will be thrown if authentication have access to this `Account` value (or an error will be thrown if authentication
fails). fails).
```haskell ```haskell
-- | We need to specify the data returned after authentication -- | We need to specify the data returned after authentication
type instance AuthServerData (AuthProtect "cookie-auth") = User type instance AuthServerData (AuthProtect "cookie-auth") = Account
``` ```
Note that we specify the type-level tag `"cookie-auth"` when defining the type Note 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:
-- | 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.
serverContext :: Context (AuthHandler Request User ': '[]) genAuthServerContext :: Context (AuthHandler Request Account ': '[])
serverContext = authHandler :. EmptyContext genAuthServerContext = authHandler :. EmptyContext
-- | Our API, where we provide all the author-supplied handlers for each end -- | Our API, where we provide all the author-supplied handlers for each end
-- point. Note that 'privateDataFunc' is a function that takes 'User' as an -- point. Note that 'privateDataFunc' is a function that takes 'Account' as an
-- argument. We dont' worry about the authentication instrumentation here, -- argument. We dont' worry about the authentication instrumentation here,
-- that is taken care of by supplying context -- that is taken care of by supplying context
server :: Server AuthGenAPI genAuthServer :: Server AuthGenAPI
server = genAuthServer =
let privateDataFunc (User name) = let privateDataFunc (Account name) =
return [PrivateData ("this is a secret: " <> name)] return (PrivateData ("this is a secret: " <> name))
publicData = [PublicData "this is a public piece of data"] publicData = return [PublicData "this is a public piece of data"]
in privateDataFunc :<|> return publicData in privateDataFunc :<|> publicData
``` ```
We're now ready to start our server (and provide a sample session)! We'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)!
```haskell ```haskell
-- | run our server -- | run our server
genAuthMain :: IO () genAuthMain :: IO ()
genAuthMain = run 8080 (serveWithContext api serverContext server) genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuthServer)
{- Sample Session: {- Sample Session:

View file

@ -21,3 +21,4 @@ through
Client.lhs Client.lhs
Javascript.lhs Javascript.lhs
Docs.lhs Docs.lhs
Authentication.lhs

View file

@ -11,6 +11,7 @@ cabal-version: >=1.10
library library
exposed-modules: ApiType exposed-modules: ApiType
, Authentication
, Client , Client
, Docs , Docs
, Javascript , Javascript
@ -23,6 +24,7 @@ library
, blaze-html , blaze-html
, directory , directory
, blaze-markup , blaze-markup
, containers
, servant == 0.5.* , servant == 0.5.*
, servant-server == 0.5.* , servant-server == 0.5.*
, servant-client == 0.5.* , servant-client == 0.5.*