summaryrefslogtreecommitdiff
path: root/gravatar.ur
diff options
context:
space:
mode:
Diffstat (limited to 'gravatar.ur')
-rw-r--r--gravatar.ur99
1 files changed, 99 insertions, 0 deletions
diff --git a/gravatar.ur b/gravatar.ur
new file mode 100644
index 0000000..2ecbdde
--- /dev/null
+++ b/gravatar.ur
@@ -0,0 +1,99 @@
+(* Copyright 2015 the Massachusetts Institute of Technology
+
+Licensed under the Apache License, Version 2.0 (the "License"); you may not use
+this file except in compliance with the License. You may obtain a copy of the
+License at
+
+ http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software distributed
+under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR
+CONDITIONS OF ANY KIND, either express or implied. See the License for the
+specific language governing permissions and limitations under the License. *)
+
+fun separate_with (sep : string) (xs : list string) : string =
+ List.foldr (fn result x => case x of
+ "" => result
+ | _ => strcat x (strcat sep result))
+ ""
+ xs
+
+structure Options = struct
+ datatype missing_image_response =
+ FourOhFour
+ | MysteryMan
+ | Identicon
+ | Monster
+ | Wavatar
+ | Retro
+ | Blank
+ | Url of url
+
+ val show_missing_image_response : show missing_image_response =
+ mkShow (fn r =>
+ case r of
+ FourOhFour => "404"
+ | MysteryMan => "mm"
+ | Identicon => "identicon"
+ | Monster => "monsterid"
+ | Wavatar => "wavatar"
+ | Retro => "retro"
+ | Blank => "blank"
+ | Url u => show u)
+
+ datatype rating = G | PG | R | X
+
+ val show_rating : show rating =
+ mkShow (fn r =>
+ case r of
+ G => "g"
+ | PG => "pg"
+ | R => "r"
+ | X => "x")
+
+ type t = {
+ Size : option int,
+ Default : option missing_image_response,
+ ForceDefault : bool,
+ Rating : option rating
+ }
+
+ (* Converts a possibly null value to a component in an HTTP query string. *)
+ fun parameter_string [a] (show_a : show a)
+ (url_key : string) (value : option a)
+ : string =
+ case value of
+ None => ""
+ | Some v => strcat url_key (strcat "=" (@show show_a v))
+
+ (* Generates a list of the components in the HTTP query string corresponding
+ to [options]. *)
+ fun query_string_elements (options : t) : list string =
+ parameter_string "s" options.Size
+ :: parameter_string "d" options.Default
+ :: (case options.ForceDefault of
+ False => ""
+ | True => "f=y")
+ :: parameter_string "r" options.Rating
+ :: []
+
+ fun to_query_string (options : t) : string =
+ case (separate_with "&" (query_string_elements options)) of
+ "" => ""
+ | query_string =>
+ (* Hey, we got some. Stick a "?" at the beginning so it can be used
+ as a query string. *)
+ strcat "?" query_string
+ end
+
+fun calculate_hash email =
+ show (Hash.md5 (textBlob (String.mp tolower (String.trim email))))
+
+fun url' options email =
+ bless
+ (strcat "https://secure.gravatar.com/avatar/"
+ (strcat (calculate_hash email)
+ (Options.to_query_string options)))
+
+fun url email =
+ url' {Size = None, Default = None, ForceDefault = False, Rating = None} email