init.sml

   1 structure Init :> INIT =
   2 struct
   3
   4 open Util Sql Config
   5 structure C = PgClient
   6
   7 fun nullableFromSql f x =
   8     if C.isNull x then
   9         NONE
  10     else
  11         SOME (f x)
  12 fun nullableToSql f x =
  13     case x of
  14         NONE => "NULL"
  15       | SOME x => f x
  16
  17 exception Access of string
  18 exception NeedTos
  19
  20 fun conn () = C.conn dbstring
  21 val close = C.close
  22
  23 type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
  24              app : int, shares : int, paypal : string option, checkout : string option }
  25
  26 val db = ref (NONE : C.conn option)
  27 val user = ref (NONE : user option)
  28
  29 fun fromSql v =
  30     if C.isNull v then
  31         "NULL"
  32     else
  33         C.stringFromSql v
  34
  35 fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs)
  36
  37 fun getDb () = valOf (!db)
  38
  39 fun mkUserRow [id, name, rname, bal, joined, app, shares, paypal, checkout] =
  40     {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
  41      bal = C.intFromSql bal, joined = C.timestampFromSql joined,
  42      app = C.intFromSql app, shares = C.intFromSql shares,
  43      paypal = nullableFromSql C.stringFromSql paypal,
  44      checkout = nullableFromSql C.stringFromSql checkout}
  45   | mkUserRow row = rowError ("user", row)
  46
  47 fun init () =
  48     let
  49         val _ = Util.init ()
  50
  51         val c = conn ()
  52     in
  53         db := SOME c;
  54         C.dml c "BEGIN";
  55         case Web.getCgi "REMOTE_USER" of
  56             NONE => raise Fail "Not logged in"
  57           | SOME name =>
  58             let
  59                 val name =
  60                     if String.isSuffix kerberosSuffix name then
  61                         String.substring (name, 0, size name - size kerberosSuffix)
  62                     else
  63                         name
  64             in
  65                 case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
  66                                         FROM WebUserActive
  67                                         WHERE name=^(C.stringToSql name)`) of
  68                     NONE => raise Fail "User not found"
  69                   | SOME r =>
  70                     let
  71                         val r = mkUserRow r
  72                     in
  73                         user := SOME r;
  74                         case C.oneOrNoRows c ($`SELECT ipaddr
  75                                                 FROM MemberApp
  76                                                 WHERE id = ^(C.intToSql (#app r))
  77                                                                 AND ipaddr IS NOT NULL`) of
  78                             NONE =>
  79                             if Web.getParam "agree" = "on" then
  80                                 (case Web.getCgi "REMOTE_ADDR" of
  81                                      NONE => raise Fail "REMOTE_ADDR not set"
  82                                    | SOME ra =>
  83                                      ignore (C.dml c ($`UPDATE MemberApp
  84                                                         SET ipaddr = ^(C.stringToSql ra),
  85                                                           applied = CURRENT_TIMESTAMP
  86                                                         WHERE id = ^(C.intToSql (#app r))`)))
  87                             else
  88                                 raise NeedTos
  89                           | _ => ()
  90                     end
  91             end
  92     end
  93
  94 fun done () =
  95     let
  96         val db = getDb ()
  97     in
  98         C.dml db "COMMIT";
  99         close db
 100     end
 101
 102 fun getUser () = valOf (!user)
 103 fun getUserId () = #id (getUser ())
 104 fun getUserName () = #name (getUser ())
 105
 106 fun lookupUser id =
 107     mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 108                                       FROM WebUser
 109                                       WHERE id = ^(C.intToSql id)`))
 110
 111 fun listUsers () =
 112     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 113                                   FROM WebUser
 114                                   ORDER BY name`)
 115
 116 fun listActiveUsers () =
 117     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 118                                   FROM WebUserActive
 119                                   ORDER BY name`)
 120
 121 fun nextSeq (db, seq) =
 122     case C.oneRow db ($`SELECT nextval('^(seq)')`) of
 123         [id] => C.intFromSql id
 124       | _ => raise Fail "Bad next sequence val"
 125
 126 fun addUser (name, rname, bal, app, shares) =
 127     let
 128         val db = getDb ()
 129         val id = nextSeq (db, "WebUserSeq")
 130     in
 131         C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares, paypal, checkout)
 132                     VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
 133                             CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares),
 134                             (SELECT paypal FROM MemberApp WHERE id = ^(C.intToSql app)),
 135                             (SELECT checkout FROM MemberApp WHERE id = ^(C.intToSql app)))`);
 136         id
 137     end
 138
 139 fun modUser (user : user) =
 140     let
 141         val db = getDb ()
 142     in
 143         ignore (C.dml db ($`UPDATE WebUser SET
 144                             name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
 145                                bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
 146                                shares = ^(C.intToSql (#shares user)),
 147                                paypal = ^(nullableToSql (C.stringToSql o Util.normEmail) (#paypal user)),
 148                                checkout = ^(nullableToSql (C.stringToSql o Util.normEmail) (#checkout user))
 149                             WHERE id = ^(C.intToSql (#id user))`))
 150     end
 151
 152 fun byPledge () =
 153     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 154                                   FROM WebUserPaying
 155                                   WHERE shares > 1
 156                                   ORDER BY shares DESC, name`)
 157
 158 fun deleteUser id =
 159     C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
 160
 161 fun validUsername name =
 162     size name <= 12
 163     andalso size name > 0
 164     andalso Char.isLower (String.sub (name, 0))
 165     andalso CharVector.all Char.isAlphaNum name
 166
 167 fun userNameToId name =
 168     case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
 169         SOME [id] => SOME (C.intFromSql id)
 170       | _ => NONE
 171
 172 fun dateString () =
 173     case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
 174         [d] => C.stringFromSql d
 175       | r => rowError ("dateString", r)
 176
 177 type node = {id : int, name : string, descr : string, debian : string}
 178
 179 fun mkNodeRow [id, name, descr, debian] =
 180     {id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr,
 181      debian = C.stringFromSql debian}
 182   | mkNodeRow row = rowError ("node", row)
 183
 184 fun listNodes () =
 185     C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian
 186                                   FROM WebNode
 187                                   WHERE id IN (SELECT id FROM ActiveWebNode)
 188                                   ORDER BY name`)
 189
 190 fun nodeName id =
 191     case C.oneRow (getDb ()) ($`SELECT name
 192                                 FROM WebNode
 193                                 WHERE id = ^(C.intToSql id)`) of
 194         [name] => C.stringFromSql name
 195       | row => rowError ("nodeName", row)
 196
 197 fun nodeDebian id =
 198     case C.oneRow (getDb ()) ($`SELECT debian
 199                                 FROM WebNode
 200                                 WHERE id = ^(C.intToSql id)`) of
 201         [debian] => C.stringFromSql debian
 202       | row => rowError ("nodeDebian", row)
 203
 204 fun explain e =
 205     case e of
 206         OS.SysErr (name, sop) =>
 207         "System error: " ^ name ^
 208         (case sop of
 209              NONE => ""
 210            | SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr)
 211       | _ => "Unknown"
 212
 213 fun tokens () =
 214     let
 215         val proc = Unix.execute ("/usr/bin/tokens", [])
 216         val inf = Unix.textInstreamOf proc
 217
 218         fun reader acc =
 219             case TextIO.inputLine inf of
 220                 NONE => String.concat (rev acc)
 221               | SOME s => reader (s :: acc)
 222     in
 223         reader []
 224         before (TextIO.closeIn inf;
 225                 ignore (Unix.reap proc))
 226     end
 227
 228 fun tokensForked () =
 229     case Posix.Process.fork () of
 230         NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child";
 231                  OS.Process.exit OS.Process.success)
 232       | _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent")
 233
 234 fun usersDiff (ls1, ls2) =
 235     {onlyInFirst = List.filter (fn x => not (Util.mem (x, ls2))) ls1,
 236      onlyInSecond = List.filter (fn x => not (Util.mem (x, ls1))) ls2}
 237
 238 fun listUsernames () = C.map (getDb ())
 239                              (fn [name] => C.stringFromSql name
 240                                | row => rowError ("listUsernames", row))
 241                              "SELECT name FROM WebUserActive ORDER BY name"
 242 fun usersInAfs () =
 243     let
 244         fun explore (dir, level, acc) =
 245             if level = 3 then
 246                 dir :: acc
 247             else
 248                 let
 249                     val dr = Posix.FileSys.opendir dir
 250
 251                     fun loop acc =
 252                         case Posix.FileSys.readdir dr of
 253                             NONE => acc
 254                           | SOME name =>
 255                             let
 256                                 val dir' = OS.Path.joinDirFile {dir = dir,
 257                                                                 file = name}
 258
 259                                 val acc = explore (dir', level+1, acc)
 260                             in
 261                                 loop acc
 262                             end
 263                 in
 264                     loop acc
 265                     before Posix.FileSys.closedir dr
 266                 end
 267
 268         val acc = explore ("/afs/hcoop.net/user", 0, [])
 269     in
 270         List.map OS.Path.file acc
 271     end
 272
 273 fun searchPaypal paypal =
 274     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 275                                   FROM WebUser
 276                                   WHERE paypal = ^(C.stringToSql (normEmail paypal))
 277                                   ORDER BY name`)
 278
 279 fun searchCheckout checkout =
 280     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 281                                   FROM WebUser
 282                                   WHERE checkout = ^(C.stringToSql (normEmail checkout))
 283                                   ORDER BY name`)
 284
 285 fun searchRealName realname =
 286     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 287                                   FROM WebUser
 288                                   WHERE rname ILIKE (^(C.stringToSql "%") || trim (both ^(C.stringToSql " ") from ^(C.stringToSql realname)) || ^(C.stringToSql "%"))
 289                                   ORDER BY name`)
 290
 291 end