changeset 6:99496175078b

Added preliminary versions of all the authentication verification steps
author Adam Chlipala <adam@chlipala.net>
date Mon, 27 Dec 2010 13:18:02 -0500
parents 443f27cd1572
children 976121190b2d
files include/openid.h src/c/openid.c src/ur/lib.urp src/ur/openid.ur src/ur/openidFfi.urs
diffstat 5 files changed, 194 insertions(+), 9 deletions(-) [+]
line wrap: on
line diff
--- a/include/openid.h	Sun Dec 26 17:36:07 2010 -0500
+++ b/include/openid.h	Mon Dec 27 13:18:02 2010 -0500
@@ -19,3 +19,5 @@
 
 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);
+
+uw_Basis_string uw_OpenidFfi_sha256(uw_context, uw_Basis_string);
--- a/src/c/openid.c	Sun Dec 26 17:36:07 2010 -0500
+++ b/src/c/openid.c	Mon Dec 27 13:18:02 2010 -0500
@@ -1,5 +1,8 @@
 #include <string.h>
 
+#include <openssl/bio.h>
+#include <openssl/evp.h>
+#include <openssl/buffer.h>
 #include <openssl/sha.h>
 #include <curl/curl.h>
 #include <expat.h>
@@ -251,6 +254,8 @@
 
   uw_buffer_init(BUF_MAX, b, BUF_INIT);
 
+  fields = uw_strdup(ctx, fields);
+
   while (*fields) {
     char *equal = strchr(fields, '='), *and, *s;
 
@@ -276,3 +281,31 @@
   uw_buffer_append(b, "", 1);
   return b;
 }
+
+static uw_Basis_string base64(uw_context ctx, unsigned char *input, int length) {
+  BIO *bmem, *b64;
+  BUF_MEM *bptr;
+
+  b64 = BIO_new(BIO_f_base64());
+  bmem = BIO_new(BIO_s_mem());
+  b64 = BIO_push(b64, bmem);
+  BIO_write(b64, input, length);
+  (void)BIO_flush(b64);
+  BIO_get_mem_ptr(b64, &bptr);
+
+  char *buff = uw_malloc(ctx, bptr->length);
+  memcpy(buff, bptr->data, bptr->length-1);
+  buff[bptr->length-1] = 0;
+
+  BIO_free_all(b64);
+
+  return buff;
+}
+
+uw_Basis_string uw_OpenidFfi_sha256(uw_context ctx, uw_Basis_string s) {
+  unsigned char out[SHA256_DIGEST_LENGTH];
+
+  SHA256((unsigned char *)s, strlen(s), out);
+
+  return base64(ctx, out, sizeof out);
+}
--- a/src/ur/lib.urp	Sun Dec 26 17:36:07 2010 -0500
+++ b/src/ur/lib.urp	Mon Dec 27 13:18:02 2010 -0500
@@ -7,5 +7,6 @@
 effectful OpenidFfi.addInput
 effectful OpenidFfi.indirect
 
+$/string
 $/option
 openid
--- a/src/ur/openid.ur	Sun Dec 26 17:36:07 2010 -0500
+++ b/src/ur/openid.ur	Mon Dec 27 13:18:02 2010 -0500
@@ -1,9 +1,26 @@
+val discoveryExpiry = 3600
+val nonceExpiry = 3600
+
 task initialize = fn () => OpenidFfi.init
 
+table discoveries : { Identifier : string, Endpoint : string, Expires : time }
+  PRIMARY KEY Identifier
+
 fun discover s =
-    r <- OpenidFfi.discover s;
-    return (Option.mp (fn r => {Endpoint = OpenidFfi.endpoint r,
-                                LocalId = OpenidFfi.localId r}) r)
+    endpoint <- oneOrNoRowsE1 (SELECT (discoveries.Endpoint)
+                               FROM discoveries
+                               WHERE discoveries.Identifier = {[s]});
+    case endpoint of
+        Some ep => return (Some ep)
+      | None =>
+        r <- OpenidFfi.discover s;
+        case r of
+            None => return None
+          | Some r =>
+            tm <- now;
+            dml (INSERT INTO discoveries (Identifier, Endpoint, Expires)
+                 VALUES ({[s]}, {[OpenidFfi.endpoint r]}, {[addSeconds tm discoveryExpiry]}));
+            return (Some (OpenidFfi.endpoint r))
 
 val createInputs =
     is <- OpenidFfi.createInputs;
@@ -13,8 +30,6 @@
 table associations : { Endpoint : string, Handle : string, Key : string, Expires : time }
   PRIMARY KEY Endpoint
 
-task periodic 1 = fn () => dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP)
-
 datatype association = Association of {Handle : string, Key : string} | AssError of string
 
 fun association url =
@@ -44,6 +59,108 @@
                      return (Association {Handle = handle, Key = key}))
               | _ => return (AssError "Missing fields in response from OP")
 
+fun eatFragment s =
+    case String.split s #"#" of
+        Some (_, s') => s'
+      | _ => s
+
+datatype handle_result = HandleOk of string | HandleError of string
+
+fun verifyHandle os id =
+    ep <- discover (eatFragment id);
+    case ep of
+        None => return (HandleError "Discovery failed on returned endpoint")
+      | Some ep =>
+        case OpenidFfi.getOutput os "openid.assoc_handle" of
+            None => return (HandleError "Missing association handle in response")
+          | Some handle =>
+            assoc <- association ep;
+            case assoc of
+                AssError s => return (HandleError s)
+              | Association assoc =>
+                if assoc.Handle <> handle then
+                    return (HandleError "Association handles don't match")
+                else
+                    return (HandleOk ep)
+
+table nonces : { Endpoint : string, Nonce : string, Expires : time }
+  PRIMARY KEY (Endpoint, Nonce)
+
+fun timeOfNonce s =
+    case String.split s #"T" of
+        None => None
+      | Some (date, s) =>
+        case String.split s #"Z" of
+            None => None
+          | Some (time, _) => read (date ^ " " ^ time)
+
+fun verifyNonce os ep =
+    case OpenidFfi.getOutput os "openid.response_nonce" of
+        None => return (Some "Missing nonce in OP response")
+      | Some nonce =>
+        case timeOfNonce nonce of
+            None => return (Some "Invalid timestamp in nonce")
+          | Some tm =>
+            now <- now;
+            exp <- return (addSeconds now nonceExpiry);
+            if tm < exp then
+                return (Some "Nonce timestamp is too old")
+            else
+                b <- oneRowE1 (SELECT COUNT( * ) > 0
+                               FROM nonces
+                               WHERE nonces.Endpoint = {[ep]}
+                                 AND nonces.Nonce = {[nonce]});
+
+                if b then
+                    return (Some "Duplicate nonce")
+                else
+                    dml (INSERT INTO nonces (Endpoint, Nonce, Expires)
+                         VALUES ({[ep]}, {[nonce]}, {[exp]}));
+                    return None
+
+fun verifySig os =
+    case OpenidFfi.getOutput os "openid.signed" of
+        None => return (Some "Missing openid.signed in OP response")
+      | Some signed =>
+        case OpenidFfi.getOutput os "openid.sig" of
+            None => return (Some "Missing openid.sig in OP response")
+          | Some sign => let
+                fun gatherNvps signed acc =
+                    let
+                        val (this, next) =
+                            case String.split signed #"," of
+                                None => (signed, None)
+                              | Some (this, next) => (this, Some next)
+                    in
+                        case OpenidFfi.getOutput os ("openid." ^ this) of
+                            None => None
+                          | Some value =>
+                            let
+                                val acc = acc ^ this ^ ":" ^ value ^ "\n"
+                            in
+                                case next of
+                                    None => Some acc
+                                  | Some next => gatherNvps next acc
+                            end
+                    end
+            in    
+                case gatherNvps signed "" of
+                    None => return (Some "openid.signed mentions missing field")
+                  | Some nvps =>
+                    let
+                        val sign' = OpenidFfi.sha256 nvps
+                    in
+                        debug ("Fields: " ^ signed);
+                        debug ("Nvps: " ^ nvps);
+                        debug ("His: " ^ sign);
+                        debug ("Mine: " ^ sign');
+                        if sign' = sign then
+                            return None
+                        else
+                            return (Some "Signatures don't match")
+                    end
+            end
+
 fun returnTo (qs : option queryString) =
     case qs of
         None => error <xml>Empty query string for OpenID callback</xml>
@@ -53,25 +170,55 @@
             Some v => error <xml>Authentication failed: {[v]}</xml>
           | None =>
             case OpenidFfi.getOutput os "openid.mode" of
-                None => error <xml>No <tt>openid.mode</tt> in response</xml>
+                None => error <xml>No <tt>openid.mode</tt> in response ({[qs]})</xml>
               | Some mode =>
                 case mode of
                     "cancel" => error <xml>You canceled the authentication!</xml>
                   | "id_res" =>
                     (case OpenidFfi.getOutput os "openid.identity" of
                          None => error <xml>Missing identity in OP response</xml>
-                       | Some v => return <xml>Identity: {[v]}</xml>)
+                       | Some id =>
+                         errO <- verifyHandle os id;
+                         case errO of
+                             HandleError s => error <xml>{[s]}</xml>
+                           | HandleOk ep =>
+                             errO <- verifyReturnTo os;
+                             case errO of
+                                 Some s => error <xml>{[s]}</xml>
+                               | None =>
+                                 errO <- verifyNonce os ep;
+                                 case errO of
+                                     Some s => error <xml>{[s]}</xml>
+                                   | None =>
+                                     errO <- verifySig os;
+                                     case errO of
+                                         Some s => error <xml>{[s]}</xml>
+                                       | None => return <xml>Identity: {[id]}</xml>)
                   | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml>
 
+and verifyReturnTo os =
+    case OpenidFfi.getOutput os "openid.return_to" of
+        None => return (Some "Missing return_to in OP response")
+      | Some rt =>
+        if rt <> show (effectfulUrl returnTo) then
+            return (Some "Wrong return_to in OP response")
+        else
+            return None
+
 fun authenticate id =
     dy <- discover id;
     case dy of
         None => return "Discovery failed"
       | Some dy =>
-        assoc <- association dy.Endpoint;
+        assoc <- association dy;
         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="
+            redirect (bless (dy ^ "?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)))
+
+task periodic 1 = fn () =>
+                     dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);
+                     dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP);
+                     dml (DELETE FROM nonces WHERE Expires < CURRENT_TIMESTAMP)
--- a/src/ur/openidFfi.urs	Sun Dec 26 17:36:07 2010 -0500
+++ b/src/ur/openidFfi.urs	Mon Dec 27 13:18:02 2010 -0500
@@ -14,3 +14,5 @@
 
 val direct : string -> inputs -> transaction outputs
 val indirect : queryString -> transaction outputs
+
+val sha256 : string -> string