OpenID Connect

urweb · Jun 19, 2020 · fa3ce03 · fa3ce03
1 parent 7bb27eb
commit fa3ce03
Show file tree

Hide file tree

Showing 7 changed files with 167 additions and 0 deletions.
diff --git a/examples/.gitignore b/examples/.gitignore
@@ -2,3 +2,4 @@ basic_in.ur
 *.exe
 *.sql
 zoomSecrets.ur
+oidcSecrets.ur
diff --git a/examples/oidc.ur b/examples/oidc.ur
@@ -0,0 +1,23 @@
+structure O = OpenIdConnect.Make(struct
+                                     open OidcSecrets
+
+                                     val authorize_url = bless "https://oidc.csail.mit.edu/authorize"
+                                     val access_token_url = bless "https://oidc.csail.mit.edu/token"
+                                     val userinfo_url = bless "https://oidc.csail.mit.edu/userinfo"
+                                     val https = False
+                                     val onCompletion = return <xml>It worked.</xml>
+                                 end)
+
+val main =
+    email <- O.whoami;
+    name <- O.name;
+    return <xml><body>
+      <a link={O.authorize}>Authorize</a>
+      <hr/>
+      {case email of
+           None => <xml></xml>
+         | Some email => <xml><p><b>E-mail:</b> {[email]}</p></xml>}
+      {case name of
+           None => <xml></xml>
+         | Some name => <xml><p><b>Name:</b> {[name]}</p></xml>}
+    </body></xml>
diff --git a/examples/oidc.urp b/examples/oidc.urp
@@ -0,0 +1,10 @@
+library ../src/ur
+rewrite all Oidc/*
+database dbname=oidc
+sql oidc.sql
+safeGetDefault
+allow url https://*
+prefix http://localhost:8080/
+
+oidcSecrets
+oidc
diff --git a/examples/oidc.urs b/examples/oidc.urs
@@ -0,0 +1 @@
+val main : transaction page
diff --git a/src/ur/lib.urp b/src/ur/lib.urp
@@ -20,3 +20,4 @@ google
 hotcrp
 salesforce
 zoom
+openIdConnect
diff --git a/src/ur/openIdConnect.ur b/src/ur/openIdConnect.ur
@@ -0,0 +1,115 @@
+open Json
+
+table secrets : { Email : string,
+                  Nam : string,
+                  Secret : int }
+  PRIMARY KEY Email
+
+cookie user : { Email : string, Secret : int }
+
+signature S = sig
+    val authorize_url : url
+    val access_token_url : url
+    val userinfo_url : url
+    val client_id : string
+    val client_secret : string
+    val https : bool
+    val onCompletion : transaction page
+end
+
+type claims = {
+     Email : option string,
+     Nam : option string,
+     GivenName : option string,
+     MiddleName : option string,
+     FamilyName : option string,
+     EmailVerified : option bool
+}
+val _ : json claims = json_record_withOptional {}
+                      {Email = "email",
+                       Nam = "name",
+                       GivenName = "given_name",
+                       MiddleName = "middle_name",
+                       FamilyName = "family_name",
+                       EmailVerified = "email_verified"}
+
+fun concato (s1 : option string) (s2 : option string) =
+    case s1 of
+        None => s2
+      | Some s1' =>
+        case s2 of
+            None => s1
+          | Some s2' => Some (s1' ^ " " ^ s2')
+
+functor Make(M : S) = struct
+    open M
+
+    fun withToken {Token = tok, ...} =
+        claims <- WorldFfi.get userinfo_url (Some ("Bearer " ^ tok)) False;
+        claims <- return (fromJson claims : claims);
+        name <- return (case claims.Nam of
+                            Some name => name
+                          | None =>
+                            case concato claims.GivenName
+                                         (concato claims.MiddleName claims.FamilyName) of
+                                None => error <xml>No name in response from OpenID Connect server</xml>
+                              | Some name => name);
+        case claims.Email of
+            None => error <xml>No e-mail address in response from OpenID Connect server</xml>
+          | Some email =>
+            (if claims.EmailVerified = Some True then
+                 return ()
+             else
+                 error <xml>OpenID Connect server returned an unverified e-mail address.</xml>);
+            secret <- oneOrNoRowsE1 (SELECT (secrets.Secret)
+                                     FROM secrets
+                                     WHERE secrets.Email = {[email]});
+            secret <- (case secret of
+                           Some secret =>
+                           dml (UPDATE secrets
+                                SET Nam = {[name]}
+                                WHERE Email = {[email]});
+                           return secret
+                         | None =>
+                           secret <- rand;
+                           dml (INSERT INTO secrets(Email, Nam, Secret)
+                            VALUES ({[email]}, {[name]}, {[secret]}));
+                           return secret);
+
+            setCookie user {Value = {Email = email, Secret = secret},
+                            Expires = None,
+                            Secure = https}
+
+    open Oauth.Make(struct
+                        open M
+
+                        val withToken = withToken
+                        val scope = None
+                    end)
+
+    val whoami =
+        c <- getCookie user;
+        case c of
+            None => return None
+          | Some r =>
+            ok <- oneRowE1 (SELECT COUNT( * ) > 0
+                            FROM secrets
+                            WHERE secrets.Email = {[r.Email]}
+                              AND secrets.Secret = {[r.Secret]});
+            if ok then
+                return (Some r.Email)
+            else
+                return None
+
+    val name =
+        c <- getCookie user;
+        case c of
+            None => return None
+          | Some r =>
+            oneOrNoRowsE1 (SELECT (secrets.Nam)
+                           FROM secrets
+                           WHERE secrets.Email = {[r.Email]}
+                             AND secrets.Secret = {[r.Secret]})
+
+    val logout = clearCookie user
+end
diff --git a/src/ur/openIdConnect.urs b/src/ur/openIdConnect.urs
@@ -0,0 +1,16 @@
+signature S = sig
+    val authorize_url : url
+    val access_token_url : url
+    val userinfo_url : url
+    val client_id : string
+    val client_secret : string
+    val https : bool
+    val onCompletion : transaction page
+end
+
+functor Make(M : S) : sig
+    val authorize : transaction page
+    val whoami : transaction (option string)
+    val name : transaction (option string)
+    val logout : transaction unit
+end
-Original file line number
+Diff line change
@@ Expand Up / @@ -2,3 +2,4 @@ basic_in.ur @@
     *.exe
     *.sql
     zoomSecrets.ur
+    oidcSecrets.ur