GitHub authentication and profile caching

examples/basic.ur

@@ -1,12 +1,11 @@
-structure O = Oauth.Make(struct
+structure G = Github.Make(struct
                              open Basic_in
-
-                             val authorize_url = bless "https://github.com/login/oauth/authorize"
-                             val access_token_url = bless "https://github.com/login/oauth/access_token"
+                             val https = False
                          end)
 
 val after =
-    return <xml>Welcome back.</xml>
+    u <- G.whoami;
+    return <xml>Welcome back, {[u]}.</xml>
 
 fun main () =
-    O.authorize {ReturnTo = url after}
+    G.authorize {ReturnTo = url after}

examples/basic.urp

@@ -1,7 +1,8 @@
 rewrite all Basic/*
 library ../src/ur
 safeGet main
-allow url https://github.com/*
+allow url https://*
+allow url http://localhost:8080/*
 database dbname=basic
 sql basic.sql
 prefix http://localhost:8080/

include/world.h

@@ -1,3 +1,4 @@
 #include <urweb.h>
 
 uw_Basis_string uw_WorldFfi_post(uw_context ctx, uw_Basis_string url, uw_Basis_string body);
+uw_Basis_string uw_WorldFfi_get(uw_context ctx, uw_Basis_string url, uw_Basis_string auth);

src/c/world.c

@@ -30,37 +30,102 @@ static size_t write_buffer_data(void *buffer, size_t size, size_t nmemb, void *u
 }
 
 static const char curl_failure[] = "error=fetch_url&error_description=";
+static const char server_failure[] = "error=fetch_url&error_description=";
 
-uw_Basis_string uw_WorldFfi_post(uw_context ctx, uw_Basis_string url, uw_Basis_string body) {
+static uw_Basis_string doweb(uw_context ctx, CURL *c, uw_Basis_string url, int encode_errors) {
   if (strncmp(url, "https://", 8))
-    uw_error(ctx, FATAL, "World: POST URL is not HTTPS");
+    uw_error(ctx, FATAL, "World: URL is not HTTPS");
 
   uw_buffer *buf = uw_malloc(ctx, sizeof(uw_buffer));
   char error_buffer[CURL_ERROR_SIZE];
-  CURL *c = curl(ctx);
   CURLcode code;
 
   uw_buffer_init(BUF_MAX, buf, BUF_INIT);
+  uw_push_cleanup(ctx, (void (*)(void *))uw_buffer_free, buf);
 
-  curl_easy_reset(c);
   curl_easy_setopt(c, CURLOPT_URL, url);
-  curl_easy_setopt(c, CURLOPT_POSTFIELDS, body);
   curl_easy_setopt(c, CURLOPT_WRITEFUNCTION, write_buffer_data);
   curl_easy_setopt(c, CURLOPT_WRITEDATA, buf);
   curl_easy_setopt(c, CURLOPT_ERRORBUFFER, error_buffer);
 
   code = curl_easy_perform(c);
 
   if (code) {
-    uw_buffer_reset(buf);
-    uw_buffer_append(buf, curl_failure, sizeof curl_failure - 1);
-    char *message = curl_easy_escape(c, error_buffer, 0);
-    uw_buffer_append(buf, message, strlen(message));
-    curl_free(message);
-  } else
-    uw_buffer_append(buf, "", 1);
+    if (encode_errors) {
+      uw_buffer_reset(buf);
+      uw_buffer_append(buf, curl_failure, sizeof curl_failure - 1);
+      char *message = curl_easy_escape(c, error_buffer, 0);
+      uw_buffer_append(buf, message, strlen(message));
+      curl_free(message);
+    } else
+      uw_error(ctx, FATAL, "Error fetching URL: %s", error_buffer);
+  } else {
+    long http_code;
+    curl_easy_getinfo(c, CURLINFO_RESPONSE_CODE, &http_code);
+
+    if (http_code == 200)
+      uw_buffer_append(buf, "", 1);
+    else if (encode_errors) {
+      uw_buffer_reset(buf);
+      uw_buffer_append(buf, server_failure, sizeof server_failure - 1);
+      char *message = curl_easy_escape(c, error_buffer, 0);
+      uw_buffer_append(buf, message, strlen(message));
+      curl_free(message);
+    } else {
+      uw_buffer_append(buf, "", 1);
+      uw_error(ctx, FATAL, "Error response from remote server: %s", buf->start);
+    }
+  } 
 
   char *ret = uw_strdup(ctx, buf->start);
-  uw_buffer_free(buf);
+  uw_pop_cleanup(ctx);
+  return ret;
+}
+
+uw_Basis_string uw_WorldFfi_post(uw_context ctx, uw_Basis_string url, uw_Basis_string body) {
+  uw_Basis_string lastUrl = uw_get_global(ctx, "world.lastUrl");
+  if (lastUrl && !strcmp(lastUrl, url)) {
+      uw_Basis_string lastBody = uw_get_global(ctx, "world.lastBody");
+      if (lastBody && !strcmp(lastBody, body)) {
+        uw_Basis_string lastResponse = uw_get_global(ctx, "world.lastResponse");
+        if (!lastResponse)
+          uw_error(ctx, FATAL, "Missing response in World cache");
+        return lastResponse;
+      }
+  }
+
+  CURL *c = curl(ctx);
+
+  curl_easy_reset(c);
+  curl_easy_setopt(c, CURLOPT_POSTFIELDS, body);
+
+  uw_Basis_string ret = doweb(ctx, c, url, 1);
+  uw_set_global(ctx, "world.lastUrl", strdup(url), free);
+  uw_set_global(ctx, "world.lastBody", strdup(body), free);
+  uw_set_global(ctx, "world.lastResponse", strdup(ret), free);
+  return ret;
+}
+
+uw_Basis_string uw_WorldFfi_get(uw_context ctx, uw_Basis_string url, uw_Basis_string auth) {
+  CURL *c = curl(ctx);
+
+  curl_easy_reset(c);
+
+  if (auth) {
+    struct curl_slist *slist = NULL;
+
+    uw_Basis_string header = uw_Basis_strcat(ctx, "Authorization: token ", auth);
+    slist = curl_slist_append(slist, header);
+    slist = curl_slist_append(slist, "User-Agent: Ur/Web World library");
+
+    if (slist == NULL)
+      uw_error(ctx, FATAL, "Can't append to libcurl slist");
+
+    curl_easy_setopt(c, CURLOPT_HTTPHEADER, slist);
+    uw_push_cleanup(ctx, (void (*)(void *))curl_slist_free_all, slist);
+  }
+
+  uw_Basis_string ret = doweb(ctx, c, url, 0);
+  uw_pop_cleanup(ctx);
   return ret;
 }

src/ur/github.ur

@@ -0,0 +1,112 @@
+open Json
+
+table users : { Login : string,
+                AvatarUrl : string,
+                Nam : option string,
+                Company : option string,
+                Blog : option string,
+                Location : option string,
+                Email : option string,
+                Hireable : option bool,
+                Bio : option string }
+  PRIMARY KEY Login
+
+con users_hidden_constraints = _
+constraint [Pkey = [Login]] ~ users_hidden_constraints
+
+table secrets : { Login : string,
+                  Secret : int }
+  PRIMARY KEY Login,
+  CONSTRAINT Login FOREIGN KEY Login REFERENCES users(Login) ON DELETE CASCADE
+
+cookie user : { Login : string, Secret : int }
+
+signature S = sig
+    val client_id : string
+    val client_secret : string
+    val https : bool
+end
+
+type profile = { Login : string,
+                 AvatarUrl : string,
+                 Nam : option string,
+                 Company : option string,
+                 Blog : option string,
+                 Location : option string,
+                 Email : option string,
+                 Hireable : option bool,
+                 Bio : option string }
+
+val json_profile : json profile =
+    json_record {Login = "login",
+                 AvatarUrl = "avatar_url",
+                 Nam = "name",
+                 Company = "company",
+                 Blog = "blog",
+                 Location = "location",
+                 Email = "email",
+                 Hireable = "hireable",
+                 Bio = "bio"}
+
+functor Make(M : S) = struct
+    open M
+
+    fun withToken tok =
+        profile <- WorldFfi.get (bless "https://api.github.com/user") (Some tok);
+        debug profile;
+        (profile : profile) <- return (Json.fromJson profile);
+        exists <- oneRowE1 (SELECT COUNT( * ) > 0
+                            FROM users
+                            WHERE users.Login = {[profile.Login]});
+        secret <-
+        (if exists then
+             dml (UPDATE users
+                  SET AvatarUrl = {[profile.AvatarUrl]},
+                    Nam = {[profile.Nam]},
+                    Company = {[profile.Company]},
+                    Blog = {[profile.Blog]},
+                    Location = {[profile.Location]},
+                    Email = {[profile.Email]},
+                    Hireable = {[profile.Hireable]},
+                    Bio = {[profile.Bio]}
+                  WHERE Login = {[profile.Login]});
+             oneRowE1 (SELECT (secrets.Secret)
+                       FROM secrets
+                       WHERE secrets.Login = {[profile.Login]})
+         else
+             dml (INSERT INTO users(Login, AvatarUrl, Nam, Company, Blog, Location,
+                      Email, Hireable, Bio)
+                  VALUES ({[profile.Login]}, {[profile.AvatarUrl]}, {[profile.Nam]},
+                      {[profile.Company]}, {[profile.Blog]}, {[profile.Location]},
+                      {[profile.Email]}, {[profile.Hireable]}, {[profile.Bio]}));
+             secret <- rand;
+             dml (INSERT INTO secrets(Login, Secret)
+                  VALUES ({[profile.Login]}, {[secret]}));
+             return secret);
+
+        setCookie user {Value = {Login = profile.Login, Secret = secret},
+                        Expires = None,
+                        Secure = https}
+
+    open Oauth.Make(struct
+                        open M
+
+                        val authorize_url = bless "https://github.com/login/oauth/authorize"
+                        val access_token_url = bless "https://github.com/login/oauth/access_token"
+                        val withToken = withToken
+                    end)
+
+    val whoami =
+        c <- getCookie user;
+        case c of
+            None => return None
+          | Some r =>
+            ok <- oneRowE1 (SELECT COUNT( * ) > 0
+                            FROM secrets
+                            WHERE secrets.Login = {[r.Login]}
+                              AND secrets.Secret = {[r.Secret]});
+            if ok then
+                return (Some r.Login)
+            else
+                error <xml>Invalid login information</xml>
+end

src/ur/github.urs

@@ -0,0 +1,21 @@
+table users : { Login : string,
+                AvatarUrl : string,
+                Nam : option string,
+                Company : option string,
+                Blog : option string,
+                Location : option string,
+                Email : option string,
+                Hireable : option bool,
+                Bio : option string }
+  PRIMARY KEY Login
+
+signature S = sig
+    val client_id : string
+    val client_secret : string
+    val https : bool
+end
+
+functor Make(M : S) : sig
+    val authorize : { ReturnTo : url } -> transaction page
+    val whoami : transaction (option string)
+end

src/ur/lib.urp

@@ -5,5 +5,7 @@ effectful WorldFfi.post
 
 $/char
 $/string
+$/json
 urls
 oauth
+github

src/ur/oauth.ur

@@ -6,6 +6,8 @@ signature S = sig
 
     val client_id : string
     val client_secret : string
+
+    val withToken : string -> transaction unit
 end
 
 table states : { State : int, Expires : time }
@@ -92,7 +94,8 @@ functor Make(M : S) = struct
                             case token of
                                 Error msg => error <xml>OAuth error: {[msg]}</xml>
                               | Token token =>
-                                return <xml>Token: {[token]}</xml>
+                                withToken token;
+                                redirect (bless rt)
                     end
         in
             state <- rand;

src/ur/oauth.urs

@@ -4,6 +4,8 @@ signature S = sig
 
     val client_id : string
     val client_secret : string
+
+    val withToken : string -> transaction unit
 end
 
 functor Make(M : S) : sig

src/ur/worldFfi.urs

@@ -1 +1,2 @@
 val post : url -> string -> transaction string
+val get : url -> option string -> transaction string