# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1293394283 18000
# Node ID f59083771ee270d47c150818a7fafdd07bbf5150
# Parent  b757dc2bd2f66aeb100674b6019f991df9dff439
Saving associations

diff -r b757dc2bd2f6 -r f59083771ee2 .hgignore
--- a/.hgignore	Sun Dec 26 13:28:06 2010 -0500
+++ b/.hgignore	Sun Dec 26 15:11:23 2010 -0500
@@ -8,6 +8,7 @@
 *.lo
 *.la
 *.exe
+*.sql
 
 *.cache
 *.log
diff -r b757dc2bd2f6 -r f59083771ee2 include/openid.h
--- a/include/openid.h	Sun Dec 26 13:28:06 2010 -0500
+++ b/include/openid.h	Sun Dec 26 15:11:23 2010 -0500
@@ -1,9 +1,20 @@
 #include <urweb/urweb.h>
 
+uw_unit uw_OpenidFfi_init(uw_context);
+
 typedef struct uw_OpenidFfi_discovery *uw_OpenidFfi_discovery;
 
 uw_Basis_string uw_OpenidFfi_endpoint(uw_context, uw_OpenidFfi_discovery);
 uw_Basis_string uw_OpenidFfi_localId(uw_context, uw_OpenidFfi_discovery);
 
-uw_unit uw_OpenidFfi_init(uw_context);
 uw_OpenidFfi_discovery *uw_OpenidFfi_discover(uw_context, uw_Basis_string id);
+
+typedef uw_buffer *uw_OpenidFfi_inputs;
+typedef uw_buffer *uw_OpenidFfi_outputs;
+
+uw_OpenidFfi_inputs uw_OpenidFfi_createInputs(uw_context);
+uw_unit uw_OpenidFfi_addInput(uw_context, uw_OpenidFfi_inputs, uw_Basis_string key, uw_Basis_string value);
+
+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);
diff -r b757dc2bd2f6 -r f59083771ee2 src/c/openid.c
--- a/src/c/openid.c	Sun Dec 26 13:28:06 2010 -0500
+++ b/src/c/openid.c	Sun Dec 26 15:11:23 2010 -0500
@@ -6,6 +6,9 @@
 
 #include <openid.h>
 
+#define BUF_MAX 10240
+#define BUF_INIT 1024
+
 struct uw_OpenidFfi_discovery {
   uw_Basis_string endpoint, localId;
 };
@@ -72,10 +75,10 @@
 typedef struct {
   XML_Parser parser;
   int any_errors;
-} curl_data;
+} curl_discovery_data;
 
-static size_t write_data(void *buffer, size_t size, size_t nmemb, void *userp) {
-  curl_data *d = userp;
+static size_t write_discovery_data(void *buffer, size_t size, size_t nmemb, void *userp) {
+  curl_discovery_data *d = userp;
 
   if (!XML_Parse(d->parser, buffer, size * nmemb, 0))
     d->any_errors = 1;
@@ -86,7 +89,7 @@
 uw_OpenidFfi_discovery *uw_OpenidFfi_discover(uw_context ctx, uw_Basis_string id) {
   char *s;
   CURL *c = curl(ctx);
-  curl_data cd = {};
+  curl_discovery_data cd = {};
   uw_OpenidFfi_discovery dy = uw_malloc(ctx, sizeof(struct uw_OpenidFfi_discovery));
   endpoint ep = {ctx, dy};
   CURLcode code;
@@ -110,7 +113,7 @@
   XML_SetElementHandler(cd.parser, startElement, endElement);
 
   curl_easy_setopt(c, CURLOPT_URL, id);
-  curl_easy_setopt(c, CURLOPT_WRITEFUNCTION, write_data);
+  curl_easy_setopt(c, CURLOPT_WRITEFUNCTION, write_discovery_data);
   curl_easy_setopt(c, CURLOPT_WRITEDATA, &cd);
 
   code = curl_easy_perform(c);
@@ -124,3 +127,101 @@
     return dyp;
   }
 }
+
+uw_OpenidFfi_inputs uw_OpenidFfi_createInputs(uw_context ctx) {
+  uw_buffer *r = uw_malloc(ctx, sizeof(uw_buffer));
+  uw_buffer_init(BUF_MAX, r, BUF_INIT);
+  return r;
+}
+
+static int okForPost(const char *s) {
+  for (; *s; ++s)
+    if (*s == '=' || *s == '&')
+      return 0;
+  return 1;
+}
+
+uw_unit uw_OpenidFfi_addInput(uw_context ctx, uw_OpenidFfi_inputs buf, uw_Basis_string key, uw_Basis_string value) {
+  if (!okForPost(key))
+    uw_error(ctx, FATAL, "Invalid key for OpenID inputs");
+  if (!okForPost(value))
+    uw_error(ctx, FATAL, "Invalid value for OpenID inputs");
+
+  if (uw_buffer_used(buf) > 0)
+    uw_buffer_append(buf, "&", 1);
+
+  uw_buffer_append(buf, key, strlen(key));
+  uw_buffer_append(buf, "=", 1);
+  uw_buffer_append(buf, value, strlen(value));
+
+  return uw_unit_v;
+}
+
+uw_Basis_string uw_OpenidFfi_getOutput(uw_context ctx, uw_OpenidFfi_outputs buf, uw_Basis_string key) {
+  char *s = buf->start;
+
+  for (; *s; s = strchr(strchr(s, 0)+1, 0)+1)
+    if (!strcmp(key, s))
+      return strchr(s, 0)+1;
+
+  return NULL;
+}
+
+static size_t write_buffer_data(void *buffer, size_t size, size_t nmemb, void *userp) {
+  uw_buffer *buf = userp;
+
+  uw_buffer_append(buf, buffer, size * nmemb);
+
+  return size * nmemb;
+}
+
+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_buffer *buf = uw_malloc(ctx, sizeof(uw_buffer));
+  CURL *c = curl(ctx);
+  CURLcode code;
+
+  uw_buffer_init(BUF_MAX, buf, BUF_INIT);
+
+  uw_buffer_append(inps, "", 1);
+
+  curl_easy_setopt(c, CURLOPT_URL, url);
+  curl_easy_setopt(c, CURLOPT_POSTFIELDS, inps->start);
+  curl_easy_setopt(c, CURLOPT_WRITEFUNCTION, write_buffer_data);
+  curl_easy_setopt(c, CURLOPT_WRITEDATA, buf);
+
+  code = curl_easy_perform(c);
+
+  uw_buffer_append(buf, "", 1);
+
+  if (code) {
+    uw_buffer_reset(buf);
+    uw_buffer_append(buf, curl_failure, sizeof curl_failure);
+  } else {
+    char *s;
+
+    s = buf->start;
+    while (*s) {
+      char *colon = strchr(s, ':'), *newline;
+
+      if (!colon) {
+        *s = 0;
+        break;
+      }
+
+      newline = strchr(colon+1, '\n');
+
+      if (!newline) {
+        *s = 0;
+        break;
+      }
+
+      *colon = 0;
+      *newline = 0;
+      s = newline+1;
+    }
+  }
+
+  return buf;
+}
diff -r b757dc2bd2f6 -r f59083771ee2 src/ur/lib.urp
--- a/src/ur/lib.urp	Sun Dec 26 13:28:06 2010 -0500
+++ b/src/ur/lib.urp	Sun Dec 26 15:11:23 2010 -0500
@@ -3,6 +3,9 @@
 link -lurweb_openid -lexpat
 effectful OpenidFfi.init
 effectful OpenidFfi.discover
+effectful OpenidFfi.createInputs
+effectful OpenidFfi.addInput
+effectful OpenidFfi.indirect
 
 $/option
 openid
diff -r b757dc2bd2f6 -r f59083771ee2 src/ur/openid.ur
--- 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")
diff -r b757dc2bd2f6 -r f59083771ee2 src/ur/openid.urs
--- a/src/ur/openid.urs	Sun Dec 26 13:28:06 2010 -0500
+++ b/src/ur/openid.urs	Sun Dec 26 15:11:23 2010 -0500
@@ -1,1 +1,4 @@
 val discover : string -> transaction (option {Endpoint : string, LocalId : option string})
+
+datatype association = Handle of string | Error of string
+val association : string -> transaction association
diff -r b757dc2bd2f6 -r f59083771ee2 src/ur/openidFfi.urs
--- a/src/ur/openidFfi.urs	Sun Dec 26 13:28:06 2010 -0500
+++ b/src/ur/openidFfi.urs	Sun Dec 26 15:11:23 2010 -0500
@@ -4,3 +4,12 @@
 val discover : string -> transaction (option discovery)
 val endpoint : discovery -> string
 val localId : discovery -> option string
+
+type inputs
+val createInputs : transaction inputs
+val addInput : inputs -> string -> string -> transaction {}
+
+type outputs
+val getOutput : outputs -> string -> option string
+
+val indirect : string -> inputs -> transaction outputs
diff -r b757dc2bd2f6 -r f59083771ee2 tests/test.ur
--- a/tests/test.ur	Sun Dec 26 13:28:06 2010 -0500
+++ b/tests/test.ur	Sun Dec 26 15:11:23 2010 -0500
@@ -2,10 +2,11 @@
     dy <- Openid.discover r.Id;
     case dy of
         None => return <xml>No dice</xml>
-      | Some dy => return <xml><body>
-        Endpoint: {[dy.Endpoint]}<br/>
-        Local ID: {[dy.LocalId]}<br/>
-      </body></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 main () = return <xml><body>
   <form>
diff -r b757dc2bd2f6 -r f59083771ee2 tests/test.urp
--- a/tests/test.urp	Sun Dec 26 13:28:06 2010 -0500
+++ b/tests/test.urp	Sun Dec 26 15:11:23 2010 -0500
@@ -1,4 +1,6 @@
 library ../src/ur
 rewrite all Test/*
+database dbname=openid
+sql test.sql
 
 test