Merge pull request #1171 from haskell-servant/issue-1088-squash
Adding OIDC Cookbook
This commit is contained in:
commit
94e00d3c74
7 changed files with 529 additions and 3 deletions
12
.travis.yml
12
.travis.yml
|
@ -4,7 +4,7 @@
|
|||
#
|
||||
# For more information, see https://github.com/haskell-CI/haskell-ci
|
||||
#
|
||||
# version: 0.3.20190326
|
||||
# version: 0.3.20190413
|
||||
#
|
||||
language: c
|
||||
dist: xenial
|
||||
|
@ -122,6 +122,7 @@ install:
|
|||
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "doc/cookbook/structuring-apis"' >> cabal.project ; fi
|
||||
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "doc/cookbook/using-custom-monad"' >> cabal.project ; fi
|
||||
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "doc/cookbook/using-free-client"' >> cabal.project ; fi
|
||||
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "doc/cookbook/open-id-connect"' >> cabal.project ; fi
|
||||
- |
|
||||
echo "constraints: foundation >=0.0.14" >> cabal.project
|
||||
echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project
|
||||
|
@ -132,7 +133,7 @@ install:
|
|||
echo "allow-newer: servant-quickcheck:http-client" >> cabal.project
|
||||
echo "optimization: False" >> cabal.project
|
||||
echo "write-ghc-environment-files: always" >> cabal.project
|
||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-https|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-https|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|open-id-connect|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||
- cat cabal.project || true
|
||||
- cat cabal.project.local || true
|
||||
- if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi
|
||||
|
@ -159,6 +160,10 @@ install:
|
|||
- if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi
|
||||
- if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi
|
||||
- if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi
|
||||
- if [ -f "doc/cookbook/open-id-connect/configure.ac" ]; then (cd "doc/cookbook/open-id-connect" && autoreconf -i); fi
|
||||
- ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output
|
||||
- "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
|
||||
- rm cabal.project.freeze
|
||||
script:
|
||||
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
|
||||
# Packaging...
|
||||
|
@ -198,6 +203,7 @@ script:
|
|||
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "cookbook-structuring-apis-*/*.cabal"' >> cabal.project ; fi
|
||||
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "cookbook-using-custom-monad-*/*.cabal"' >> cabal.project ; fi
|
||||
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "cookbook-using-free-client-*/*.cabal"' >> cabal.project ; fi
|
||||
if [ $HCNUMVER -eq 80404 ] || [ $HCNUMVER -eq 80604 ] ; then echo 'packages: "open-id-connect-*/*.cabal"' >> cabal.project ; fi
|
||||
- |
|
||||
echo "constraints: foundation >=0.0.14" >> cabal.project
|
||||
echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project
|
||||
|
@ -208,7 +214,7 @@ script:
|
|||
echo "allow-newer: servant-quickcheck:http-client" >> cabal.project
|
||||
echo "optimization: False" >> cabal.project
|
||||
echo "write-ghc-environment-files: always" >> cabal.project
|
||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-https|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-db-sqlite-simple|cookbook-file-upload|cookbook-generic|cookbook-https|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|open-id-connect|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||
- cat cabal.project || true
|
||||
- cat cabal.project.local || true
|
||||
- echo -en 'travis_fold:end:unpack\\r'
|
||||
|
|
|
@ -30,6 +30,7 @@ packages:
|
|||
doc/cookbook/structuring-apis
|
||||
doc/cookbook/using-custom-monad
|
||||
doc/cookbook/using-free-client
|
||||
doc/cookbook/open-id-connect
|
||||
|
||||
tests: True
|
||||
optimization: False
|
||||
|
|
|
@ -12,6 +12,7 @@ packages:
|
|||
pagination/
|
||||
sentry/
|
||||
testing/
|
||||
open-id-connect/
|
||||
../../servant
|
||||
../../servant-server
|
||||
../../servant-client-core
|
||||
|
|
0
doc/cookbook/cabal.project.local
Normal file
0
doc/cookbook/cabal.project.local
Normal file
|
@ -32,3 +32,4 @@ you name it!
|
|||
curl-mock/CurlMock.lhs
|
||||
sentry/Sentry.lhs
|
||||
testing/Testing.lhs
|
||||
open-id-connect/OpenIdConnect.lhs
|
||||
|
|
45
doc/cookbook/open-id-connect/OpenIdConnect.cabal
Normal file
45
doc/cookbook/open-id-connect/OpenIdConnect.cabal
Normal file
|
@ -0,0 +1,45 @@
|
|||
name: open-id-connect
|
||||
version: 0.1
|
||||
synopsis: OpenId Connect with Servant example
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
license: BSD3
|
||||
license-file: ../../../servant/LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
tested-with: GHC==8.4.4, GHC==8.6.4
|
||||
|
||||
executable cookbook-openidconnect
|
||||
main-is: OpenIdConnect.lhs
|
||||
build-depends: base ==4.*
|
||||
, aeson
|
||||
, aeson-pretty
|
||||
, binary
|
||||
, blaze-html
|
||||
, blaze-markup
|
||||
, bytestring
|
||||
, case-insensitive
|
||||
, cereal
|
||||
, containers
|
||||
, generic-lens
|
||||
, http-client
|
||||
, http-client-tls
|
||||
, http-types
|
||||
, jose-jwt
|
||||
, lens
|
||||
, lens-aeson
|
||||
, oidc-client
|
||||
, protolude
|
||||
, random
|
||||
, servant
|
||||
, servant-blaze
|
||||
, servant-server
|
||||
, text
|
||||
, time
|
||||
, vector
|
||||
, wai
|
||||
, warp >= 3.2
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances -pgmL markdown-unlit
|
||||
build-tool-depends: markdown-unlit:markdown-unlit >= 0.4
|
472
doc/cookbook/open-id-connect/OpenIdConnect.lhs
Normal file
472
doc/cookbook/open-id-connect/OpenIdConnect.lhs
Normal file
|
@ -0,0 +1,472 @@
|
|||
[OpenID Connect](https://openid.net/connect/)
|
||||
=============================================
|
||||
|
||||
Use OpenID Connect to authenticate your users.
|
||||
This example use google OIDC provider.
|
||||
It was made for a working with single page application where
|
||||
some login token would be saved in the user agent local storage.
|
||||
|
||||
Workflow:
|
||||
|
||||
1. user is presentend with a login button,
|
||||
2. when the user click on the button it is redirected to the OIDC
|
||||
provider,
|
||||
3. the user login in the OIDC provider,
|
||||
4. the OIDC provider will redirect the user and provide a `code`,
|
||||
5. the server will use this code to make a POST to the OIDC provider
|
||||
and will get back authentication infos,
|
||||
6. The user will get display an HTML page that will save a secret
|
||||
identifying him in the local storage, then it will be redirected to
|
||||
/.
|
||||
|
||||
Let's put the imports behind us:
|
||||
|
||||
``` haskell
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Protolude
|
||||
|
||||
import Data.Aeson
|
||||
(FromJSON (..), (.:))
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Types as AeT
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Text as Text
|
||||
import Jose.Jwt
|
||||
(Jwt (..), decodeClaims)
|
||||
import Network.HTTP.Client
|
||||
(Manager, newManager)
|
||||
import Network.HTTP.Client.TLS
|
||||
(tlsManagerSettings)
|
||||
import Network.Wai.Handler.Warp
|
||||
(run)
|
||||
import Servant
|
||||
import Servant.HTML.Blaze
|
||||
(HTML)
|
||||
import qualified System.Random as Random
|
||||
import Text.Blaze
|
||||
(ToMarkup (..))
|
||||
import qualified Text.Blaze.Html as H
|
||||
import Text.Blaze.Html5
|
||||
((!))
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
import Text.Blaze.Renderer.Utf8
|
||||
(renderMarkup)
|
||||
import qualified Web.OIDC.Client as O
|
||||
```
|
||||
|
||||
You'll need to create a new OpenID Connect client in an OpenID Provider.
|
||||
This example was tested with Google.
|
||||
|
||||
You can find a list of public OIDC provider here:
|
||||
https://connect2id.com/products/nimbus-oauth-openid-connect-sdk/openid-connect-providers
|
||||
|
||||
I copied some here:
|
||||
|
||||
- Google: https://developers.google.com/identity/protocols/OpenIDConnect
|
||||
more precisely: https://console.developers.google.com/apis/credentials
|
||||
- Microsoft: https://docs.microsoft.com/en-us/previous-versions/azure/dn645541(v=azure.100)
|
||||
- Yahoo: https://developer.yahoo.com/oauth2/guide/openid_connect/
|
||||
- PayPal: https://developer.paypal.com/docs/integration/direct/identity/log-in-with-paypal/
|
||||
|
||||
During the configuration you'll need to provide a redirect uri.
|
||||
The redirect_uri should correspond to the uri user will be redirected to
|
||||
after a successful login into the OpenID provider.
|
||||
|
||||
So during your test, you should certainly just use `http://localhost:3000/login/cb`.
|
||||
In general you should use your own domain name.
|
||||
|
||||
You'll then be given a `client_id` and a `client_password`.
|
||||
Fill those values in here:
|
||||
|
||||
``` haskell
|
||||
oidcConf :: OIDCConf
|
||||
oidcConf = OIDCConf { redirectUri = "http://localhost:3000/login/cb"
|
||||
, clientId = "xxxxxxxxxxxx-xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx.apps.googleusercontent.com"
|
||||
, clientPassword = "************************" }
|
||||
```
|
||||
|
||||
Then we declare our main server:
|
||||
|
||||
``` haskell
|
||||
main :: IO ()
|
||||
main = do
|
||||
oidcEnv <- initOIDC oidcConf
|
||||
run 3000 (app oidcEnv)
|
||||
|
||||
type API = IdentityRoutes Customer
|
||||
:<|> Get '[HTML] Homepage
|
||||
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
server :: OIDCEnv -> Server API
|
||||
server oidcEnv = serveOIDC oidcEnv handleOIDCLogin
|
||||
:<|> return Homepage
|
||||
|
||||
-- | Then main app
|
||||
app :: OIDCEnv -> Application
|
||||
app oidcEnv = serve api (server oidcEnv)
|
||||
```
|
||||
|
||||
OIDC
|
||||
----
|
||||
|
||||
That part try to separate concern, and certainly in a real world
|
||||
application that should be in its distinct module.
|
||||
|
||||
``` haskell
|
||||
-- * OIDC
|
||||
|
||||
data OIDCConf =
|
||||
OIDCConf { redirectUri :: ByteString
|
||||
, clientId :: ByteString
|
||||
, clientPassword :: ByteString
|
||||
} deriving (Show, Eq)
|
||||
```
|
||||
|
||||
First we need to initialize OIDC.
|
||||
A short explanation about it:
|
||||
|
||||
- to complete the workflow we need to make a POST request to the OIDC provider.
|
||||
So we need to create an http manager to make those call properly.
|
||||
- Then in order to prevent replay attack, each time an user wants to login we
|
||||
should provide a random string called the `state`. When the user is
|
||||
redirected to the `redirect_uri`, the OIDC provider should provide the same
|
||||
`state` along a `code` parameter.
|
||||
|
||||
``` haskell
|
||||
initOIDC :: OIDCConf -> IO OIDCEnv
|
||||
initOIDC OIDCConf{..} = do
|
||||
mgr <- newManager tlsManagerSettings
|
||||
prov <- O.discover "https://accounts.google.com" mgr
|
||||
let oidc = O.setCredentials clientId clientPassword redirectUri (O.newOIDC prov)
|
||||
return OIDCEnv { oidc = oidc
|
||||
, mgr = mgr
|
||||
, genState = genRandomBS
|
||||
, prov = prov
|
||||
, redirectUri = redirectUri
|
||||
, clientId = clientId
|
||||
, clientPassword = clientPassword
|
||||
}
|
||||
|
||||
data OIDCEnv = OIDCEnv { oidc :: O.OIDC
|
||||
, mgr :: Manager
|
||||
, genState :: IO ByteString
|
||||
, prov :: O.Provider
|
||||
, redirectUri :: ByteString
|
||||
, clientId :: ByteString
|
||||
, clientPassword :: ByteString
|
||||
}
|
||||
```
|
||||
|
||||
The `IdentityRoutes` are two endpoints:
|
||||
|
||||
- an endpoint to redirect the users to the OIDC Provider,
|
||||
- another one the user will be redirected to from the OIDC Provider.
|
||||
|
||||
``` haskell
|
||||
type IdentityRoutes a =
|
||||
"login" :> ( -- redirect User to the OpenID Provider
|
||||
Get '[JSON] NoContent
|
||||
-- render the page that will save the user creds in the user-agent
|
||||
:<|> "cb" :> QueryParam "error" Text
|
||||
:> QueryParam "code" Text
|
||||
:> Get '[HTML] User)
|
||||
|
||||
-- | gen a 302 redirect helper
|
||||
redirects :: (StringConv s ByteString) => s -> Handler ()
|
||||
redirects url = throwError err302 { errHeaders = [("Location",toS url)]}
|
||||
```
|
||||
|
||||
That function will generate the URL to redirect the users to when
|
||||
they'll click on the login link: `https://yourdomain/login`.
|
||||
|
||||
``` haskell
|
||||
genOIDCURL :: OIDCEnv -> IO ByteString
|
||||
genOIDCURL OIDCEnv{..} = do
|
||||
st <- genState -- generate a random string
|
||||
let oidcCreds = O.setCredentials clientId clientPassword redirectUri (O.newOIDC prov)
|
||||
loc <- O.getAuthenticationRequestUrl oidcCreds [O.openId, O.email, O.profile] (Just st) []
|
||||
return (show loc)
|
||||
|
||||
handleLogin :: OIDCEnv -> Handler NoContent
|
||||
handleLogin oidcenv = do
|
||||
loc <- liftIO (genOIDCURL oidcenv)
|
||||
redirects loc
|
||||
return NoContent
|
||||
```
|
||||
|
||||
The `AuthInfo` is about the infos we can grab from OIDC provider.
|
||||
|
||||
To be more precise, the user should come with a `code` (a token) and
|
||||
POSTing that code to the correct OIDC provider endpoint should return a JSON
|
||||
object. One of the field should be named `id_token` which should be a
|
||||
JWT containing all the informations we need. Depending on the scopes we
|
||||
asked we might get more informations.
|
||||
|
||||
``` haskell
|
||||
-- | @AuthInfo@
|
||||
data AuthInfo = AuthInfo { email :: Text
|
||||
, emailVerified :: Bool
|
||||
, name :: Text } deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromJSON AuthInfo where
|
||||
parseJSON (JSON.Object v) = do
|
||||
email :: Text <- v .: "email"
|
||||
email_verified :: Bool <- v .: "email_verified"
|
||||
name :: Text <- v .: "name"
|
||||
return $ AuthInfo (toS email) email_verified (toS name)
|
||||
parseJSON invalid = AeT.typeMismatch "Coord" invalid
|
||||
instance JSON.ToJSON AuthInfo where
|
||||
toJSON (AuthInfo e ev n) =
|
||||
JSON.object [ "email" JSON..= (toS e :: Text)
|
||||
, "email_verified" JSON..= ev
|
||||
, "name" JSON..= (toS n :: Text)
|
||||
]
|
||||
|
||||
type LoginHandler = AuthInfo -> IO (Either Text User)
|
||||
```
|
||||
|
||||
The `handleLoggedIn` is that part that will retrieve the informations from
|
||||
the user once he is redirected from the OIDC Provider after login.
|
||||
|
||||
If the user is redirected to the `redirect_uri` but with an `error` query
|
||||
parameter then it means something goes wrong.
|
||||
If there is no error query param but a `code` query param it means the user
|
||||
sucessfully logged in. From there we need to make a request to the token
|
||||
endpoint of the OIDC provider. Its a POST that should contains the code
|
||||
as well as the client id & secret.
|
||||
This is the role of the `requestTokens` to make this HTTP POST.
|
||||
|
||||
From there we extract the `claims` of the JWT contained in one of the value
|
||||
of the JSON returned by the POST HTTP Request.
|
||||
|
||||
``` haskell
|
||||
data User = User { userId :: Text
|
||||
, userSecret :: Text
|
||||
, localStorageKey :: Text
|
||||
, redirectUrl :: Maybe Text
|
||||
} deriving (Show,Eq,Ord)
|
||||
|
||||
handleLoggedIn :: OIDCEnv
|
||||
-> LoginHandler -- ^ handle successful id
|
||||
-> Maybe Text -- ^ error
|
||||
-> Maybe Text -- ^ code
|
||||
-> Handler User
|
||||
handleLoggedIn oidcenv handleSuccessfulId err mcode =
|
||||
case err of
|
||||
Just errorMsg -> forbidden errorMsg
|
||||
Nothing -> case mcode of
|
||||
Just oauthCode -> do
|
||||
tokens <- liftIO $ O.requestTokens (oidc oidcenv) (toS oauthCode) (mgr oidcenv)
|
||||
putText . show . O.claims . O.idToken $ tokens
|
||||
let jwt = toS . unJwt . O.jwt . O.idToken $ tokens
|
||||
eAuthInfo = decodeClaims jwt :: Either O.JwtError (O.JwtHeader,AuthInfo)
|
||||
case eAuthInfo of
|
||||
Left jwtErr -> forbidden $ "JWT decode/check problem: " <> show jwtErr
|
||||
Right (_,authInfo) ->
|
||||
if emailVerified authInfo
|
||||
then do
|
||||
user <- liftIO $ handleSuccessfulId authInfo
|
||||
either forbidden return user
|
||||
else forbidden "Please verify your email"
|
||||
Nothing -> do
|
||||
liftIO $ putText "No code param"
|
||||
forbidden "no code parameter given"
|
||||
```
|
||||
|
||||
When you render a User with blaze-html, it will generate a page with a js
|
||||
that will put a secret for that user in the local storage. And it will
|
||||
redirect the user to /.
|
||||
|
||||
``` haskell
|
||||
instance ToMarkup User where
|
||||
toMarkup User{..} = H.docTypeHtml $ do
|
||||
H.head $
|
||||
H.title "Logged In"
|
||||
H.body $ do
|
||||
H.h1 "Logged In"
|
||||
H.p (H.toHtml ("Successful login with id " <> userId))
|
||||
H.script (H.toHtml ("localStorage.setItem('" <> localStorageKey <> "','" <> userSecret <> "');"
|
||||
<> "localStorage.setItem('user-id','" <> userId <> "');"
|
||||
<> "window.location='" <> fromMaybe "/" redirectUrl <> "';" -- redirect the user to /
|
||||
));
|
||||
|
||||
serveOIDC :: OIDCEnv -> LoginHandler -> Server (IdentityRoutes a)
|
||||
serveOIDC oidcenv loginHandler =
|
||||
handleLogin oidcenv :<|> handleLoggedIn oidcenv loginHandler
|
||||
|
||||
-- * Auth
|
||||
type APIKey = ByteString
|
||||
type Account = Text.Text
|
||||
type Conf = [(APIKey,Account)]
|
||||
data Customer = Customer {
|
||||
account :: Account
|
||||
, apiKey :: APIKey
|
||||
, mail :: Maybe Text
|
||||
, fullname :: Maybe Text
|
||||
}
|
||||
```
|
||||
|
||||
Here is the code that display the homepage.
|
||||
It should contain a link to the the `/login` URL.
|
||||
When the user will click on this link it will be redirected to Google login page
|
||||
with some generated informations.
|
||||
|
||||
The page also display the content of the local storage.
|
||||
And in particular the items `api-key` and `user-id`.
|
||||
Those items should be set after a successful login when the user is redirected to
|
||||
`/login/cb`.
|
||||
|
||||
The logic used generally is to use that api-key to uniquely identify an user.
|
||||
Another option would have been to set a cookie.
|
||||
|
||||
``` haskell
|
||||
data Homepage = Homepage
|
||||
|
||||
instance ToMarkup Homepage where
|
||||
toMarkup Homepage = H.docTypeHtml $ do
|
||||
H.head $ do
|
||||
H.title "OpenID Connect Servant Example"
|
||||
H.style (H.toHtml ("body { font-family: monospace; font-size: 18px; }" :: Text.Text))
|
||||
H.body $ do
|
||||
H.h1 "OpenID Connect Servant Example"
|
||||
H.div $
|
||||
H.a ! HA.href "/login" $ "Click here to login"
|
||||
H.ul $ do
|
||||
H.li $ do
|
||||
H.span "API Key in Local storage: "
|
||||
H.script (H.toHtml ("document.write(localStorage.getItem('api-key'));" :: Text.Text))
|
||||
H.li $ do
|
||||
H.span "User ID in Local storage: "
|
||||
H.script (H.toHtml ("document.write(localStorage.getItem('user-id'));" :: Text.Text))
|
||||
```
|
||||
|
||||
We need some helpers to generate random string for generating state and API Keys.
|
||||
|
||||
``` haskell
|
||||
-- | generate a random Bystestring, not necessarily extremely good randomness
|
||||
-- still the password will be long enough to be very difficult to crack
|
||||
genRandomBS :: IO ByteString
|
||||
genRandomBS = do
|
||||
g <- Random.newStdGen
|
||||
Random.randomRs (0, n) g & take 42 & fmap toChar & readable 0 & toS & return
|
||||
where
|
||||
n = length letters - 1
|
||||
toChar i = letters List.!! i
|
||||
letters = ['A'..'Z'] <> ['0'..'9'] <> ['a'..'z']
|
||||
readable :: Int -> [Char] -> [Char]
|
||||
readable _ [] = []
|
||||
readable i str =
|
||||
let blocksize = case n of
|
||||
0 -> 8
|
||||
1 -> 4
|
||||
2 -> 4
|
||||
3 -> 4
|
||||
_ -> 12
|
||||
block = take blocksize str
|
||||
rest = drop blocksize str
|
||||
in if List.null rest
|
||||
then str
|
||||
else block <> "-" <> readable (i+1) rest
|
||||
|
||||
customerFromAuthInfo :: AuthInfo -> IO Customer
|
||||
customerFromAuthInfo authinfo = do
|
||||
apikey <- genRandomBS
|
||||
return Customer { account = toS (email authinfo)
|
||||
, apiKey = apikey
|
||||
, mail = Just (toS (email authinfo))
|
||||
, fullname = Just (toS (name authinfo))
|
||||
}
|
||||
|
||||
handleOIDCLogin :: LoginHandler
|
||||
handleOIDCLogin authInfo = do
|
||||
custInfo <- customerFromAuthInfo authInfo
|
||||
if emailVerified authInfo
|
||||
then return . Right . customerToUser $ custInfo
|
||||
else return (Left "You emails is not verified by your provider. Please verify your email.")
|
||||
where
|
||||
customerToUser :: Customer -> User
|
||||
customerToUser c =
|
||||
User { userId = toS (account c)
|
||||
, userSecret = toS (apiKey c)
|
||||
, redirectUrl = Nothing
|
||||
, localStorageKey = "api-key"
|
||||
}
|
||||
```
|
||||
|
||||
`Error` helpers
|
||||
---------------
|
||||
|
||||
``` haskell
|
||||
data Err = Err { errTitle :: Text
|
||||
, errMsg :: Text }
|
||||
|
||||
instance ToMarkup Err where
|
||||
toMarkup Err{..} = H.docTypeHtml $ do
|
||||
H.head $ do
|
||||
H.title "Error"
|
||||
H.body $ do
|
||||
H.h1 (H.a ! HA.href "/" $ "Home")
|
||||
H.h2 (H.toHtml errTitle)
|
||||
H.p (H.toHtml errMsg)
|
||||
|
||||
format :: ToMarkup a => a -> LBS.ByteString
|
||||
format err = toMarkup err & renderMarkup
|
||||
|
||||
appToErr :: ServerError -> Text -> ServerError
|
||||
appToErr x msg = x
|
||||
{ errBody = toS $ format (Err (toS (errReasonPhrase x)) msg)
|
||||
, errHeaders = [("Content-Type","text/html")]}
|
||||
|
||||
unauthorized :: (MonadError ServerError m) => Text -> m a
|
||||
unauthorized = throwError . unauthorizedErr
|
||||
|
||||
unauthorizedErr :: Text -> ServerError
|
||||
unauthorizedErr = appToErr err401
|
||||
|
||||
forbidden :: (MonadError ServerError m) => Text -> m a
|
||||
forbidden = throwError . forbiddenErr
|
||||
|
||||
forbiddenErr :: Text -> ServerError
|
||||
forbiddenErr = appToErr err403
|
||||
|
||||
notFound :: ( MonadError ServerError m) => Text -> m a
|
||||
notFound = throwError . notFoundErr
|
||||
|
||||
notFoundErr :: Text -> ServerError
|
||||
notFoundErr = appToErr err404
|
||||
|
||||
preconditionFailed :: ( MonadError ServerError m) => Text -> m a
|
||||
preconditionFailed = throwError . preconditionFailedErr
|
||||
|
||||
preconditionFailedErr :: Text -> ServerError
|
||||
preconditionFailedErr = appToErr err412
|
||||
|
||||
serverError :: ( MonadError ServerError m) => Text -> m a
|
||||
serverError = throwError . serverErrorErr
|
||||
|
||||
serverErrorErr :: Text -> ServerError
|
||||
serverErrorErr = appToErr err500
|
||||
```
|
Loading…
Reference in a new issue