contact/contact.sml

   1 structure Contact :> CONTACT =
   2 struct
   3
   4 structure C = PgClient
   5
   6 fun main _ =
   7     let
   8         val db = C.conn "dbname='hcoop_hcoop'"
   9
  10         fun allEmails () =
  11             let
  12                 fun s [v] = C.stringFromSql v
  13                   | s _ = raise Fail "Bad allEmails row"
  14             in
  15                 C.map db s
  16                       "SELECT v FROM Contact JOIN ContactKind ON knd = ContactKind.id AND ContactKind.name = 'Non-hcoop e-mail' ORDER BY v"
  17             end
  18
  19         fun kindRow [id, name, url, urlPrefix, urlPostfix] =
  20             {id = C.intFromSql id,
  21              name = C.stringFromSql name,
  22              url = if C.boolFromSql url then
  23                        SOME (C.stringFromSql urlPrefix,
  24                              C.stringFromSql urlPostfix)
  25                    else
  26                        NONE}
  27           | kindRow _ = raise Fail "Bad ContactKind row"
  28
  29         val kinds = C.map db kindRow "SELECT id, name, url, urlPrefix, urlPostfix FROM ContactKind ORDER BY name"
  30
  31         fun doOne (kind : {id : int, name : string, url : (string * string) option}) =
  32             let
  33                 fun doOne [name, v] =
  34                     let
  35                         val name = C.stringFromSql name
  36                         val v = C.stringFromSql v
  37                     in
  38                         print "<li> ";
  39                         print (Web.html name);
  40                         print ": ";
  41                         case #url kind of
  42                             NONE => print (Web.html v)
  43                           | SOME (pre, post) =>
  44                             (print "<a href=\"";
  45                              print (Web.html (pre ^ v ^ post));
  46                              print "\">";
  47                              print (Web.html v);
  48                              print "</a>");
  49                         print "</li>\n"
  50                     end
  51                   | doOne _ = raise Fail "Bad Contact row"
  52             in
  53                 print "<h2>";
  54                 print (#name kind);
  55                 print "</h2>\n<ol>\n";
  56
  57                 C.app db doOne ("SELECT name, v FROM Contact JOIN WebUserActive ON usr = WebUserActive.id"
  58                                 ^ " WHERE knd = " ^ C.intToSql (#id kind)
  59                                 ^ " ORDER BY name, v");
  60
  61                 print "</ol>\n\n"
  62             end
  63     in
  64         print "<html><head><title>HCoop Emergency Contact Information</title></head><body><h1>HCoop Emergency Contact Information</h1>\n";
  65
  66         print "<h2><a href=\"mailto:";
  67         print (String.concatWith "," (allEmails ()));
  68         print "\">E-mail everyone (off-HCoop addresses)</a></h2>\n\n";
  69
  70         app doOne kinds;
  71         print "</body></html>\n";
  72         C.close db;
  73         OS.Process.success
  74     end handle C.Sql s => (print ("SQL failure: " ^ s ^ "\n");
  75                            OS.Process.failure)
  76
  77 end