diff src/ur/openid.ur @ 3:f59083771ee2

Saving associations
author Adam Chlipala <adam@chlipala.net>
date Sun, 26 Dec 2010 15:11:23 -0500
parents b757dc2bd2f6
children 2d409aff8800
line wrap: on
line diff
--- a/src/ur/openid.ur	Sun Dec 26 13:28:06 2010 -0500
+++ b/src/ur/openid.ur	Sun Dec 26 15:11:23 2010 -0500
@@ -4,3 +4,41 @@
     r <- OpenidFfi.discover s;
     return (Option.mp (fn r => {Endpoint = OpenidFfi.endpoint r,
                                 LocalId = OpenidFfi.localId r}) r)
+
+val createInputs =
+    is <- OpenidFfi.createInputs;
+    OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0";
+    return is
+
+table associations : { Endpoint : string, Secret : string, Expires : time }
+  PRIMARY KEY Endpoint
+
+task periodic 0 = fn () => dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP)
+
+datatype association = Handle of string | Error of string
+
+fun association url =
+    secret <- oneOrNoRowsE1 (SELECT (associations.Secret)
+                             FROM associations
+                             WHERE associations.Endpoint = {[url]});
+    case secret of
+        Some v => return (Handle v)
+      | 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;
+        case OpenidFfi.getOutput os "error" of
+            Some v => return (Error v)
+          | None =>
+            case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "expires_in") of
+                (Some handle, Some expires) =>
+                (case read expires of
+                     None => return (Error "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")