Merge pull request #1171 from haskell-servant/issue-1088-squash
Adding OIDC Cookbook
This commit is contained in:
Oleg Grenrus
GitHub
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
|
# For more information, see https://github.com/haskell-CI/haskell-ci
|
||||||
#
|
#
|
||||||
# version: 0.3.20190326
|
# version: 0.3.20190413
|
||||||
#
|
#
|
||||||
language: c
|
language: c
|
||||||
dist: xenial
|
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/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-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/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: foundation >=0.0.14" >> cabal.project
|
||||||
echo "constraints: memory <0.14.12 || >0.14.12" >> 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 "allow-newer: servant-quickcheck:http-client" >> cabal.project
|
||||||
echo "optimization: False" >> cabal.project
|
echo "optimization: False" >> cabal.project
|
||||||
echo "write-ghc-environment-files: always" >> 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 || true
|
||||||
- cat cabal.project.local || true
|
- cat cabal.project.local || true
|
||||||
- if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi
|
- 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/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-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/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:
|
script:
|
||||||
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
|
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
|
||||||
# Packaging...
|
# 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-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-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: "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: foundation >=0.0.14" >> cabal.project
|
||||||
echo "constraints: memory <0.14.12 || >0.14.12" >> 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 "allow-newer: servant-quickcheck:http-client" >> cabal.project
|
||||||
echo "optimization: False" >> cabal.project
|
echo "optimization: False" >> cabal.project
|
||||||
echo "write-ghc-environment-files: always" >> 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 || true
|
||||||
- cat cabal.project.local || true
|
- cat cabal.project.local || true
|
||||||
- echo -en 'travis_fold:end:unpack\\r'
|
- echo -en 'travis_fold:end:unpack\\r'
|
||||||
|
|
|
||||||
|
|
@ -30,6 +30,7 @@ packages:
|
||||||
doc/cookbook/structuring-apis
|
doc/cookbook/structuring-apis
|
||||||
doc/cookbook/using-custom-monad
|
doc/cookbook/using-custom-monad
|
||||||
doc/cookbook/using-free-client
|
doc/cookbook/using-free-client
|
||||||
|
doc/cookbook/open-id-connect
|
||||||
|
|
||||||
tests: True
|
tests: True
|
||||||
optimization: False
|
optimization: False
|
||||||
|
|
|
||||||
|
|
@ -12,6 +12,7 @@ packages:
|
||||||
pagination/
|
pagination/
|
||||||
sentry/
|
sentry/
|
||||||
testing/
|
testing/
|
||||||
|
open-id-connect/
|
||||||
../../servant
|
../../servant
|
||||||
../../servant-server
|
../../servant-server
|
||||||
../../servant-client-core
|
../../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
|
curl-mock/CurlMock.lhs
|
||||||
sentry/Sentry.lhs
|
sentry/Sentry.lhs
|
||||||
testing/Testing.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