changeset 4:2d409aff8800

Received an OpenID authentication response, but haven't checked it yet
author Adam Chlipala <adam@chlipala.net>
date Sun, 26 Dec 2010 17:19:52 -0500
parents f59083771ee2
children 443f27cd1572
files include/openid.h src/c/openid.c src/ur/openid.ur src/ur/openid.urs src/ur/openidFfi.urs tests/test.ur tests/test.urp
diffstat 7 files changed, 106 insertions(+), 31 deletions(-) [+]
line wrap: on
line diff
--- a/include/openid.h	Sun Dec 26 15:11:23 2010 -0500
+++ b/include/openid.h	Sun Dec 26 17:19:52 2010 -0500
@@ -17,4 +17,5 @@
 
 uw_Basis_string uw_OpenidFfi_getOutput(uw_context, uw_OpenidFfi_outputs, uw_Basis_string key);
 
-uw_OpenidFfi_outputs uw_OpenidFfi_indirect(uw_context, uw_Basis_string url, uw_OpenidFfi_inputs);
+uw_OpenidFfi_outputs uw_OpenidFfi_direct(uw_context, uw_Basis_string url, uw_OpenidFfi_inputs);
+uw_OpenidFfi_outputs uw_OpenidFfi_indirect(uw_context, uw_Basis_string fields);
--- a/src/c/openid.c	Sun Dec 26 15:11:23 2010 -0500
+++ b/src/c/openid.c	Sun Dec 26 17:19:52 2010 -0500
@@ -22,6 +22,8 @@
 }
 
 uw_unit uw_OpenidFfi_init(uw_context ctx) {
+  
+
   curl_global_init(CURL_GLOBAL_ALL);
 
   return uw_unit_v;
@@ -177,7 +179,7 @@
 
 const char curl_failure[] = "error\0Error fetching URL";
 
-uw_OpenidFfi_outputs uw_OpenidFfi_indirect(uw_context ctx, uw_Basis_string url, uw_OpenidFfi_inputs inps) {
+uw_OpenidFfi_outputs uw_OpenidFfi_direct(uw_context ctx, uw_Basis_string url, uw_OpenidFfi_inputs inps) {
   uw_buffer *buf = uw_malloc(ctx, sizeof(uw_buffer));
   CURL *c = curl(ctx);
   CURLcode code;
@@ -225,3 +227,52 @@
 
   return buf;
 }
+
+static uw_Basis_string deurl(uw_context ctx, uw_Basis_string s) {
+  uw_Basis_string r = uw_malloc(ctx, strlen(s)), s2 = r;
+
+  for (; *s; ++s) {
+    if (s[0] == '%' && s[1] && s[2]) {
+      unsigned u;
+
+      sscanf(s+1, "%02x", &u);
+      *s2++ = u;
+      s += 2;
+    } else
+      *s2++ = *s;
+  }
+
+  *s2 = 0;
+  return r;
+}
+
+uw_OpenidFfi_outputs uw_OpenidFfi_indirect(uw_context ctx, uw_Basis_string fields) {
+  uw_OpenidFfi_outputs b = malloc(sizeof(uw_buffer));
+
+  uw_buffer_init(BUF_MAX, b, BUF_INIT);
+
+  while (*fields) {
+    char *equal = strchr(fields, '='), *and, *s;
+
+    if (!equal)
+      break;
+
+    *equal = 0;
+    s = deurl(ctx, fields);
+    uw_buffer_append(b, s, strlen(s));
+    uw_buffer_append(b, "", 1);
+
+    and = strchr(equal+1, '&');
+    if (and) {
+      *and = 0;
+      fields = and+1;
+    } else
+      fields = and = strchr(equal+1, 0);
+    s = deurl(ctx, equal+1);
+    uw_buffer_append(b, s, strlen(s));
+    uw_buffer_append(b, "", 1);
+  }
+
+  uw_buffer_append(b, "", 1);
+  return b;
+}
--- a/src/ur/openid.ur	Sun Dec 26 15:11:23 2010 -0500
+++ b/src/ur/openid.ur	Sun Dec 26 17:19:52 2010 -0500
@@ -10,35 +10,61 @@
     OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0";
     return is
 
-table associations : { Endpoint : string, Secret : string, Expires : time }
+table associations : { Endpoint : string, Handle : string, Key : string, Expires : time }
   PRIMARY KEY Endpoint
 
-task periodic 0 = fn () => dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP)
+task periodic 1 = fn () => dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP)
 
-datatype association = Handle of string | Error of string
+datatype association = Association of {Handle : string, Key : string} | AssError of string
 
 fun association url =
-    secret <- oneOrNoRowsE1 (SELECT (associations.Secret)
+    secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Key
                              FROM associations
                              WHERE associations.Endpoint = {[url]});
     case secret of
-        Some v => return (Handle v)
+        Some r => return (Association r)
       | None =>
         is <- createInputs;
         OpenidFfi.addInput is "openid.mode" "associate";
         OpenidFfi.addInput is "openid.assoc_type" "HMAC-SHA256";
         OpenidFfi.addInput is "openid.session_type" "no-encryption";
-        os <- OpenidFfi.indirect url is;
+
+        os <- OpenidFfi.direct url is;
         case OpenidFfi.getOutput os "error" of
-            Some v => return (Error v)
+            Some v => return (AssError v)
           | None =>
-            case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "expires_in") of
-                (Some handle, Some expires) =>
+            case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "mac_key", OpenidFfi.getOutput os "expires_in") of
+                (Some handle, Some key, Some expires) =>
                 (case read expires of
-                     None => return (Error "Invalid 'expires_in' field")
+                     None => return (AssError "Invalid 'expires_in' field")
                    | Some expires =>
                      tm <- now;
-                     dml (INSERT INTO associations (Endpoint, Secret, Expires)
-                          VALUES ({[url]}, {[handle]}, {[addSeconds tm expires]}));
-                     return (Handle handle))
-              | _ => return (Error "Missing fields in response from OP")
+                     dml (INSERT INTO associations (Endpoint, Handle, Key, Expires)
+                          VALUES ({[url]}, {[handle]}, {[key]}, {[addSeconds tm expires]}));
+                     return (Association {Handle = handle, Key = key}))
+              | _ => return (AssError "Missing fields in response from OP")
+
+fun returnTo (qs : option queryString) =
+    case qs of
+        None => error <xml>Empty query string for OpenID callback</xml>
+      | Some qs =>
+        os <- OpenidFfi.indirect qs;
+        case OpenidFfi.getOutput os "openid.error" of
+            Some v => error <xml>Authentication failed: {[v]}</xml>
+          | None =>
+            case OpenidFfi.getOutput os "openid.identity" of
+                None => error <xml>Missing identity in OP response</xml>
+              | Some v => return <xml>Identity: {[v]}</xml>
+
+fun authenticate id =
+    dy <- discover id;
+    case dy of
+        None => return "Discovery failed"
+      | Some dy =>
+        assoc <- association dy.Endpoint;
+        case assoc of
+            AssError msg => return msg
+          | Association assoc =>
+            redirect (bless (dy.Endpoint ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
+                             ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
+                             ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
--- a/src/ur/openid.urs	Sun Dec 26 15:11:23 2010 -0500
+++ b/src/ur/openid.urs	Sun Dec 26 17:19:52 2010 -0500
@@ -1,4 +1,3 @@
-val discover : string -> transaction (option {Endpoint : string, LocalId : option string})
-
-datatype association = Handle of string | Error of string
-val association : string -> transaction association
+val authenticate : string -> transaction string
+(* Doesn't return normally if everything goes as planned.
+ * Instead, the user is redirected to his OP to authenticate there. *)
--- a/src/ur/openidFfi.urs	Sun Dec 26 15:11:23 2010 -0500
+++ b/src/ur/openidFfi.urs	Sun Dec 26 17:19:52 2010 -0500
@@ -12,4 +12,5 @@
 type outputs
 val getOutput : outputs -> string -> option string
 
-val indirect : string -> inputs -> transaction outputs
+val direct : string -> inputs -> transaction outputs
+val indirect : queryString -> transaction outputs
--- a/tests/test.ur	Sun Dec 26 15:11:23 2010 -0500
+++ b/tests/test.ur	Sun Dec 26 17:19:52 2010 -0500
@@ -1,16 +1,10 @@
-fun discover r =
-    dy <- Openid.discover r.Id;
-    case dy of
-        None => return <xml>No dice</xml>
-      | Some dy =>
-        os <- Openid.association dy.Endpoint;
-        case os of
-            Openid.Error s => error <xml>{[s]}</xml>
-          | Openid.Handle s => return <xml>{[s]}</xml>
+fun auth r =
+    msg <- Openid.authenticate r.Id;
+    error <xml>{[msg]}</xml>
 
 fun main () = return <xml><body>
   <form>
     <textbox{#Id}/>
-    <submit action={discover}/>
+    <submit action={auth}/>
   </form>
 </body></xml>
--- a/tests/test.urp	Sun Dec 26 15:11:23 2010 -0500
+++ b/tests/test.urp	Sun Dec 26 17:19:52 2010 -0500
@@ -2,5 +2,8 @@
 rewrite all Test/*
 database dbname=openid
 sql test.sql
+allow url http://*
+allow url https://*
+prefix http://localhost:8080/
 
 test