@@ -0,0 +1,472 @@
1+[OpenID Connect](https://openid.net/connect/)
2+=============================================
3+
4+Use OpenID Connect to authenticate your users.
5+This example use google OIDC provider.
6+It was made for a working with single page application where
7+some login token would be saved in the user agent local storage.
8+
9+Workflow:
10+
11+1. user is presentend with a login button,
12+2. when the user click on the button it is redirected to the OIDC
13+ provider,
14+3. the user login in the OIDC provider,
15+4. the OIDC provider will redirect the user and provide a `code`,
16+5. the server will use this code to make a POST to the OIDC provider
17+ and will get back authentication infos,
18+6. The user will get display an HTML page that will save a secret
19+ identifying him in the local storage, then it will be redirected to
20+ /.
21+
22+Let's put the imports behind us:
23+
24+``` haskell
25+{-# LANGUAGE DataKinds #-}
26+{-# LANGUAGE DeriveGeneric #-}
27+{-# LANGUAGE DuplicateRecordFields #-}
28+{-# LANGUAGE FlexibleContexts #-}
29+{-# LANGUAGE FlexibleInstances #-}
30+{-# LANGUAGE MultiParamTypeClasses #-}
31+{-# LANGUAGE NoImplicitPrelude #-}
32+{-# LANGUAGE OverloadedLists #-}
33+{-# LANGUAGE OverloadedStrings #-}
34+{-# LANGUAGE PartialTypeSignatures #-}
35+{-# LANGUAGE PolyKinds #-}
36+{-# LANGUAGE RankNTypes #-}
37+{-# LANGUAGE RecordWildCards #-}
38+{-# LANGUAGE ScopedTypeVariables #-}
39+{-# LANGUAGE TypeFamilies #-}
40+{-# LANGUAGE TypeOperators #-}
41+{-# LANGUAGE TypeSynonymInstances #-}
42+
43+module Main where
44+
45+import Protolude
46+
47+import Data.Aeson
48+ (FromJSON (..), (.:))
49+import qualified Data.Aeson as JSON
50+import qualified Data.Aeson.Types as AeT
51+import qualified Data.ByteString.Lazy as LBS
52+import qualified Data.List as List
53+import qualified Data.Text as Text
54+import Jose.Jwt
55+ (Jwt (..), decodeClaims)
56+import Network.HTTP.Client
57+ (Manager, newManager)
58+import Network.HTTP.Client.TLS
59+ (tlsManagerSettings)
60+import Network.Wai.Handler.Warp
61+ (run)
62+import Servant
63+import Servant.HTML.Blaze
64+ (HTML)
65+import qualified System.Random as Random
66+import Text.Blaze
67+ (ToMarkup (..))
68+import qualified Text.Blaze.Html as H
69+import Text.Blaze.Html5
70+ ((!))
71+import qualified Text.Blaze.Html5 as H
72+import qualified Text.Blaze.Html5.Attributes as HA
73+import Text.Blaze.Renderer.Utf8
74+ (renderMarkup)
75+import qualified Web.OIDC.Client as O
76+```
77+
78+You'll need to create a new OpenID Connect client in an OpenID Provider.
79+This example was tested with Google.
80+
81+You can find a list of public OIDC provider here:
82+https://connect2id.com/products/nimbus-oauth-openid-connect-sdk/openid-connect-providers
83+
84+I copied some here:
85+
86+- Google: https://developers.google.com/identity/protocols/OpenIDConnect
87+ more precisely: https://console.developers.google.com/apis/credentials
88+- Microsoft: https://docs.microsoft.com/en-us/previous-versions/azure/dn645541(v=azure.100)
89+- Yahoo: https://developer.yahoo.com/oauth2/guide/openid_connect/
90+- PayPal: https://developer.paypal.com/docs/integration/direct/identity/log-in-with-paypal/
91+
92+During the configuration you'll need to provide a redirect uri.
93+The redirect_uri should correspond to the uri user will be redirected to
94+after a successful login into the OpenID provider.
95+
96+So during your test, you should certainly just use `http://localhost:3000/login/cb`.
97+In general you should use your own domain name.
98+
99+You'll then be given a `client_id` and a `client_password`.
100+Fill those values in here:
101+
102+``` haskell
103+oidcConf :: OIDCConf
104+oidcConf = OIDCConf { redirectUri = "http://localhost:3000/login/cb"
105+ , clientId = "xxxxxxxxxxxx-xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx.apps.googleusercontent.com"
106+ , clientPassword = "************************" }
107+```
108+
109+Then we declare our main server:
110+
111+``` haskell
112+main :: IO ()
113+main = do
114+ oidcEnv <- initOIDC oidcConf
115+ run 3000 (app oidcEnv)
116+
117+type API = IdentityRoutes Customer
118+ :<|> Get '[HTML] Homepage
119+
120+api :: Proxy API
121+api = Proxy
122+
123+server :: OIDCEnv -> Server API
124+server oidcEnv = serveOIDC oidcEnv handleOIDCLogin
125+ :<|> return Homepage
126+
127+-- | Then main app
128+app :: OIDCEnv -> Application
129+app oidcEnv = serve api (server oidcEnv)
130+```
131+
132+OIDC
133+----
134+
135+That part try to separate concern, and certainly in a real world
136+application that should be in its distinct module.
137+
138+``` haskell
139+-- * OIDC
140+
141+data OIDCConf =
142+ OIDCConf { redirectUri :: ByteString
143+ , clientId :: ByteString
144+ , clientPassword :: ByteString
145+ } deriving (Show, Eq)
146+```
147+
148+First we need to initialize OIDC.
149+A short explanation about it:
150+
151+- to complete the workflow we need to make a POST request to the OIDC provider.
152+ So we need to create an http manager to make those call properly.
153+- Then in order to prevent replay attack, each time an user wants to login we
154+ should provide a random string called the `state`. When the user is
155+ redirected to the `redirect_uri`, the OIDC provider should provide the same
156+ `state` along a `code` parameter.
157+
158+``` haskell
159+initOIDC :: OIDCConf -> IO OIDCEnv
160+initOIDC OIDCConf{..} = do
161+ mgr <- newManager tlsManagerSettings
162+ prov <- O.discover "https://accounts.google.com" mgr
163+ let oidc = O.setCredentials clientId clientPassword redirectUri (O.newOIDC prov)
164+ return OIDCEnv { oidc = oidc
165+ , mgr = mgr
166+ , genState = genRandomBS
167+ , prov = prov
168+ , redirectUri = redirectUri
169+ , clientId = clientId
170+ , clientPassword = clientPassword
171+ }
172+
173+data OIDCEnv = OIDCEnv { oidc :: O.OIDC
174+ , mgr :: Manager
175+ , genState :: IO ByteString
176+ , prov :: O.Provider
177+ , redirectUri :: ByteString
178+ , clientId :: ByteString
179+ , clientPassword :: ByteString
180+ }
181+```
182+
183+The `IdentityRoutes` are two endpoints:
184+
185+- an endpoint to redirect the users to the OIDC Provider,
186+- another one the user will be redirected to from the OIDC Provider.
187+
188+``` haskell
189+type IdentityRoutes a =
190+ "login" :> ( -- redirect User to the OpenID Provider
191+ Get '[JSON] NoContent
192+ -- render the page that will save the user creds in the user-agent
193+ :<|> "cb" :> QueryParam "error" Text
194+ :> QueryParam "code" Text
195+ :> Get '[HTML] User)
196+
197+-- | gen a 302 redirect helper
198+redirects :: (StringConv s ByteString) => s -> Handler ()
199+redirects url = throwError err302 { errHeaders = [("Location",toS url)]}
200+```
201+
202+That function will generate the URL to redirect the users to when
203+they'll click on the login link: `https://yourdomain/login`.
204+
205+``` haskell
206+genOIDCURL :: OIDCEnv -> IO ByteString
207+genOIDCURL OIDCEnv{..} = do
208+ st <- genState -- generate a random string
209+ let oidcCreds = O.setCredentials clientId clientPassword redirectUri (O.newOIDC prov)
210+ loc <- O.getAuthenticationRequestUrl oidcCreds [O.openId, O.email, O.profile] (Just st) []
211+ return (show loc)
212+
213+handleLogin :: OIDCEnv -> Handler NoContent
214+handleLogin oidcenv = do
215+ loc <- liftIO (genOIDCURL oidcenv)
216+ redirects loc
217+ return NoContent
218+```
219+
220+The `AuthInfo` is about the infos we can grab from OIDC provider.
221+
222+To be more precise, the user should come with a `code` (a token) and
223+POSTing that code to the correct OIDC provider endpoint should return a JSON
224+object. One of the field should be named `id_token` which should be a
225+JWT containing all the informations we need. Depending on the scopes we
226+asked we might get more informations.
227+
228+``` haskell
229+-- | @AuthInfo@
230+data AuthInfo = AuthInfo { email :: Text
231+ , emailVerified :: Bool
232+ , name :: Text } deriving (Eq, Show, Generic)
233+
234+instance FromJSON AuthInfo where
235+ parseJSON (JSON.Object v) = do
236+ email :: Text <- v .: "email"
237+ email_verified :: Bool <- v .: "email_verified"
238+ name :: Text <- v .: "name"
239+ return $ AuthInfo (toS email) email_verified (toS name)
240+ parseJSON invalid = AeT.typeMismatch "Coord" invalid
241+instance JSON.ToJSON AuthInfo where
242+ toJSON (AuthInfo e ev n) =
243+ JSON.object [ "email" JSON..= (toS e :: Text)
244+ , "email_verified" JSON..= ev
245+ , "name" JSON..= (toS n :: Text)
246+ ]
247+
248+type LoginHandler = AuthInfo -> IO (Either Text User)
249+```
250+
251+The `handleLoggedIn` is that part that will retrieve the informations from
252+the user once he is redirected from the OIDC Provider after login.
253+
254+If the user is redirected to the `redirect_uri` but with an `error` query
255+parameter then it means something goes wrong.
256+If there is no error query param but a `code` query param it means the user
257+sucessfully logged in. From there we need to make a request to the token
258+endpoint of the OIDC provider. Its a POST that should contains the code
259+as well as the client id & secret.
260+This is the role of the `requestTokens` to make this HTTP POST.
261+
262+From there we extract the `claims` of the JWT contained in one of the value
263+of the JSON returned by the POST HTTP Request.
264+
265+``` haskell
266+data User = User { userId :: Text
267+ , userSecret :: Text
268+ , localStorageKey :: Text
269+ , redirectUrl :: Maybe Text
270+ } deriving (Show,Eq,Ord)
271+
272+handleLoggedIn :: OIDCEnv
273+ -> LoginHandler -- ^ handle successful id
274+ -> Maybe Text -- ^ error
275+ -> Maybe Text -- ^ code
276+ -> Handler User
277+handleLoggedIn oidcenv handleSuccessfulId err mcode =
278+ case err of
279+ Just errorMsg -> forbidden errorMsg
280+ Nothing -> case mcode of
281+ Just oauthCode -> do
282+ tokens <- liftIO $ O.requestTokens (oidc oidcenv) (toS oauthCode) (mgr oidcenv)
283+ putText . show . O.claims . O.idToken $ tokens
284+ let jwt = toS . unJwt . O.jwt . O.idToken $ tokens
285+ eAuthInfo = decodeClaims jwt :: Either O.JwtError (O.JwtHeader,AuthInfo)
286+ case eAuthInfo of
287+ Left jwtErr -> forbidden $ "JWT decode/check problem: " <> show jwtErr
288+ Right (_,authInfo) ->
289+ if emailVerified authInfo
290+ then do
291+ user <- liftIO $ handleSuccessfulId authInfo
292+ either forbidden return user
293+ else forbidden "Please verify your email"
294+ Nothing -> do
295+ liftIO $ putText "No code param"
296+ forbidden "no code parameter given"
297+```
298+
299+When you render a User with blaze-html, it will generate a page with a js
300+that will put a secret for that user in the local storage. And it will
301+redirect the user to /.
302+
303+``` haskell
304+instance ToMarkup User where
305+ toMarkup User{..} = H.docTypeHtml $ do
306+ H.head $
307+ H.title "Logged In"
308+ H.body $ do
309+ H.h1 "Logged In"
310+ H.p (H.toHtml ("Successful login with id " <> userId))
311+ H.script (H.toHtml ("localStorage.setItem('" <> localStorageKey <> "','" <> userSecret <> "');"
312+ <> "localStorage.setItem('user-id','" <> userId <> "');"
313+ <> "window.location='" <> fromMaybe "/" redirectUrl <> "';" -- redirect the user to /
314+ ));
315+
316+serveOIDC :: OIDCEnv -> LoginHandler -> Server (IdentityRoutes a)
317+serveOIDC oidcenv loginHandler =
318+ handleLogin oidcenv :<|> handleLoggedIn oidcenv loginHandler
319+
320+-- * Auth
321+type APIKey = ByteString
322+type Account = Text.Text
323+type Conf = [(APIKey,Account)]
324+data Customer = Customer {
325+ account :: Account
326+ , apiKey :: APIKey
327+ , mail :: Maybe Text
328+ , fullname :: Maybe Text
329+ }
330+```
331+
332+Here is the code that display the homepage.
333+It should contain a link to the the `/login` URL.
334+When the user will click on this link it will be redirected to Google login page
335+with some generated informations.
336+
337+The page also display the content of the local storage.
338+And in particular the items `api-key` and `user-id`.
339+Those items should be set after a successful login when the user is redirected to
340+`/login/cb`.
341+
342+The logic used generally is to use that api-key to uniquely identify an user.
343+Another option would have been to set a cookie.
344+
345+``` haskell
346+data Homepage = Homepage
347+
348+instance ToMarkup Homepage where
349+ toMarkup Homepage = H.docTypeHtml $ do
350+ H.head $ do
351+ H.title "OpenID Connect Servant Example"
352+ H.style (H.toHtml ("body { font-family: monospace; font-size: 18px; }" :: Text.Text))
353+ H.body $ do
354+ H.h1 "OpenID Connect Servant Example"
355+ H.div $
356+ H.a ! HA.href "/login" $ "Click here to login"
357+ H.ul $ do
358+ H.li $ do
359+ H.span "API Key in Local storage: "
360+ H.script (H.toHtml ("document.write(localStorage.getItem('api-key'));" :: Text.Text))
361+ H.li $ do
362+ H.span "User ID in Local storage: "
363+ H.script (H.toHtml ("document.write(localStorage.getItem('user-id'));" :: Text.Text))
364+```
365+
366+We need some helpers to generate random string for generating state and API Keys.
367+
368+``` haskell
369+-- | generate a random Bystestring, not necessarily extremely good randomness
370+-- still the password will be long enough to be very difficult to crack
371+genRandomBS :: IO ByteString
372+genRandomBS = do
373+ g <- Random.newStdGen
374+ Random.randomRs (0, n) g & take 42 & fmap toChar & readable 0 & toS & return
375+ where
376+ n = length letters - 1
377+ toChar i = letters List.!! i
378+ letters = ['A'..'Z'] <> ['0'..'9'] <> ['a'..'z']
379+ readable :: Int -> [Char] -> [Char]
380+ readable _ [] = []
381+ readable i str =
382+ let blocksize = case n of
383+ 0 -> 8
384+ 1 -> 4
385+ 2 -> 4
386+ 3 -> 4
387+ _ -> 12
388+ block = take blocksize str
389+ rest = drop blocksize str
390+ in if List.null rest
391+ then str
392+ else block <> "-" <> readable (i+1) rest
393+
394+customerFromAuthInfo :: AuthInfo -> IO Customer
395+customerFromAuthInfo authinfo = do
396+ apikey <- genRandomBS
397+ return Customer { account = toS (email authinfo)
398+ , apiKey = apikey
399+ , mail = Just (toS (email authinfo))
400+ , fullname = Just (toS (name authinfo))
401+ }
402+
403+handleOIDCLogin :: LoginHandler
404+handleOIDCLogin authInfo = do
405+ custInfo <- customerFromAuthInfo authInfo
406+ if emailVerified authInfo
407+ then return . Right . customerToUser $ custInfo
408+ else return (Left "You emails is not verified by your provider. Please verify your email.")
409+ where
410+ customerToUser :: Customer -> User
411+ customerToUser c =
412+ User { userId = toS (account c)
413+ , userSecret = toS (apiKey c)
414+ , redirectUrl = Nothing
415+ , localStorageKey = "api-key"
416+ }
417+```
418+
419+`Error` helpers
420+---------------
421+
422+``` haskell
423+data Err = Err { errTitle :: Text
424+ , errMsg :: Text }
425+
426+instance ToMarkup Err where
427+ toMarkup Err{..} = H.docTypeHtml $ do
428+ H.head $ do
429+ H.title "Error"
430+ H.body $ do
431+ H.h1 (H.a ! HA.href "/" $ "Home")
432+ H.h2 (H.toHtml errTitle)
433+ H.p (H.toHtml errMsg)
434+
435+format :: ToMarkup a => a -> LBS.ByteString
436+format err = toMarkup err & renderMarkup
437+
438+appToErr :: ServerError -> Text -> ServerError
439+appToErr x msg = x
440+ { errBody = toS $ format (Err (toS (errReasonPhrase x)) msg)
441+ , errHeaders = [("Content-Type","text/html")]}
442+
443+unauthorized :: (MonadError ServerError m) => Text -> m a
444+unauthorized = throwError . unauthorizedErr
445+
446+unauthorizedErr :: Text -> ServerError
447+unauthorizedErr = appToErr err401
448+
449+forbidden :: (MonadError ServerError m) => Text -> m a
450+forbidden = throwError . forbiddenErr
451+
452+forbiddenErr :: Text -> ServerError
453+forbiddenErr = appToErr err403
454+
455+notFound :: ( MonadError ServerError m) => Text -> m a
456+notFound = throwError . notFoundErr
457+
458+notFoundErr :: Text -> ServerError
459+notFoundErr = appToErr err404
460+
461+preconditionFailed :: ( MonadError ServerError m) => Text -> m a
462+preconditionFailed = throwError . preconditionFailedErr
463+
464+preconditionFailedErr :: Text -> ServerError
465+preconditionFailedErr = appToErr err412
466+
467+serverError :: ( MonadError ServerError m) => Text -> m a
468+serverError = throwError . serverErrorErr
469+
470+serverErrorErr :: Text -> ServerError
471+serverErrorErr = appToErr err500
472+```