From 58eb6983ed830e623cf560608327fd0aea9ff32c Mon Sep 17 00:00:00 2001
From: Dan <dan@nectry.com>
Date: Tue, 29 Aug 2023 17:46:11 -0400
Subject: [PATCH] Add convenient add_params_to_url function

---
 src/ur/oauth.ur | 19 +++++++------------
 src/ur/urls.ur  | 10 ++++++++++
 src/ur/urls.urs |  7 +++++++
 3 files changed, 24 insertions(+), 12 deletions(-)

diff --git a/src/ur/oauth.ur b/src/ur/oauth.ur
index 745e167..a11a4ca 100644
--- a/src/ur/oauth.ur
+++ b/src/ur/oauth.ur
@@ -152,18 +152,13 @@ functor MakeDyn(M : sig
             dml (INSERT INTO states(State, Expires) VALUES({[state]}, {[addSeconds tm 300]}));
             settings <- settings;
 
-            redirect (bless (show settings.AuthorizeUrl
-                             ^ "?client_id=" ^ urlencode settings.ClientId
-                             ^ "&redirect_uri=" ^ urlencode (show (effectfulUrl authorized))
-                             ^ "&state=" ^ show state
-                             ^ "&response_type=code"
-                             ^ (case scope of
-                                    None => ""
-                                  | Some scope => "&" ^ Option.get "scope" nameForScopeParameter
-                                                  ^ "=" ^ urlencode scope)
-                             ^ (case hosted_domain of
-                                    None => ""
-                                  | Some hd => "&hd=" ^ urlencode hd)))
+            redirect (add_params_to_url settings.AuthorizeUrl
+              (("client_id", Some settings.ClientId),
+               ("redirect_uri", Some (show (effectfulUrl authorized))),
+               ("state", Some (show state)),
+               ("response_type", Some "code"),
+               (Option.get "scope" nameForScopeParameter, scope),
+               ("hd", hosted_domain)))
         end
 end
 
diff --git a/src/ur/urls.ur b/src/ur/urls.ur
index 94a39c4..c22ac68 100644
--- a/src/ur/urls.ur
+++ b/src/ur/urls.ur
@@ -134,3 +134,13 @@ fun base64url_encode' (getChar : int -> char) (urlVersion : bool) (len : int) =
 fun base64url_encode s = base64url_encode' (String.sub s) True (String.length s)
 fun base64url_encode_signature s = base64url_encode' (WorldFfi.byte s) True (WorldFfi.length s)
 fun base64_encode_signature s = base64url_encode' (WorldFfi.byte s) False (WorldFfi.length s)
+
+fun add_params_to_url [r] fl base_url params =
+    (* If there's a '?' in the base url, then it already has params, and we continue with '&'. *)
+    let val initialPrefix = if String.all (fn ch => ch <> #"?") (show base_url) then "?" else "&"
+        fun foldFun [nm ::_] [rest ::_] [[nm] ~ rest] (nm, op) (prefix, rst) = case op of
+                  None   => (prefix, rst)
+                | Some p => ("&", rst ^ prefix ^ nm ^ "=" ^ urlencode p)
+        val encoded_params = @foldUR [(string * option string)] [fn _ => (string * string)] foldFun (initialPrefix, "") fl params
+    in bless (show base_url ^ encoded_params.2)
+    end
diff --git a/src/ur/urls.urs b/src/ur/urls.urs
index cdb40e8..6abdcc0 100644
--- a/src/ur/urls.urs
+++ b/src/ur/urls.urs
@@ -4,3 +4,10 @@ val urldecode : string -> string
 val base64url_encode : string -> string
 val base64url_encode_signature : WorldFfi.signatur -> string
 val base64_encode_signature : WorldFfi.signatur -> string
+
+(* Takes a base URL along with a record of name/value pairs and formats the
+   pairs into the typical "base_url?nm1=val1&nm2=val2...", properly URL encoding
+   the given strings.
+   The base URL may already name/value pairs.
+   If the value is `None`, then the name/value pair is omitted from the result *)
+val add_params_to_url : r ::: {Unit} -> folder r -> url -> $(mapU (string * option string) r) -> url