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)
 132                     VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
 133                             CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`);
 134         id
 135     end
 136
 137 fun modUser (user : user) =
 138     let
 139         val db = getDb ()
 140     in
 141         ignore (C.dml db ($`UPDATE WebUser SET
 142                             name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
 143                                bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
 144                                shares = ^(C.intToSql (#shares user)),
 145                                paypal = ^(nullableToSql C.stringToSql (#paypal user)),
 146                                checkout = ^(nullableToSql C.stringToSql (#checkout user))
 147                             WHERE id = ^(C.intToSql (#id user))`))
 148     end
 149
 150 fun byPledge () =
 151     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 152                                   FROM WebUser
 153                                   WHERE shares > 1
 154                                   ORDER BY shares DESC, name`)
 155
 156 fun deleteUser id =
 157     C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
 158
 159 fun validUsername name =
 160     size name <= 10
 161     andalso size name > 0
 162     andalso Char.isLower (String.sub (name, 0))
 163     andalso CharVector.all Char.isAlphaNum name
 164
 165 fun userNameToId name =
 166     case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
 167         SOME [id] => SOME (C.intFromSql id)
 168       | _ => NONE
 169
 170 fun dateString () =
 171     case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
 172         [d] => C.stringFromSql d
 173       | r => rowError ("dateString", r)
 174
 175 fun grandfatherUsers () =
 176     let
 177         val db = getDb ()
 178
 179         fun mkApp [id, name, rname] =
 180             let
 181                 val id = C.intFromSql id
 182                 val name = C.stringFromSql name
 183                 val rname = C.stringFromSql rname
 184
 185                 val aid = nextSeq (db, "MemberAppSeq")
 186             in
 187                 ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
 188                                                         passwd, status, applied, confirmed, decided, msg)
 189                                  VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
 190                                          NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
 191                                          'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
 192                                          CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
 193                 ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
 194             end
 195     in
 196         C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
 197     end
 198
 199 type node = {id : int, name : string, descr : string, debian : string}
 200
 201 fun mkNodeRow [id, name, descr, debian] =
 202     {id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr,
 203      debian = C.stringFromSql debian}
 204   | mkNodeRow row = rowError ("node", row)
 205
 206 fun listNodes () =
 207     C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian
 208                                   FROM WebNode
 209                                   ORDER BY name`)
 210
 211 fun nodeName id =
 212     case C.oneRow (getDb ()) ($`SELECT name
 213                                 FROM WebNode
 214                                 WHERE id = ^(C.intToSql id)`) of
 215         [name] => C.stringFromSql name
 216       | row => rowError ("nodeName", row)
 217
 218 fun nodeDebian id =
 219     case C.oneRow (getDb ()) ($`SELECT debian
 220                                 FROM WebNode
 221                                 WHERE id = ^(C.intToSql id)`) of
 222         [debian] => C.stringFromSql debian
 223       | row => rowError ("nodeDebian", row)
 224
 225 fun explain e =
 226     case e of
 227         OS.SysErr (name, sop) =>
 228         "System error: " ^ name ^
 229         (case sop of
 230              NONE => ""
 231            | SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr)
 232       | _ => "Unknown"
 233
 234 fun tokens () =
 235     let
 236         val proc = Unix.execute ("/usr/bin/tokens", [])
 237         val inf = Unix.textInstreamOf proc
 238
 239         fun reader acc =
 240             case TextIO.inputLine inf of
 241                 NONE => String.concat (rev acc)
 242               | SOME s => reader (s :: acc)
 243     in
 244         reader []
 245         before (TextIO.closeIn inf;
 246                 ignore (Unix.reap proc))
 247     end
 248
 249 fun tokensForked () =
 250     case Posix.Process.fork () of
 251         NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child";
 252                  OS.Process.exit OS.Process.success)
 253       | _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent")
 254
 255 fun unmigratedUsers () =
 256     List.filter (fn user =>
 257                     (ignore (Posix.SysDB.getpwnam (#name user));
 258                      false)
 259                     handle OS.SysErr _ => true) (listActiveUsers ())
 260
 261 fun usersDiff (ls1, ls2) =
 262     {onlyInFirst = List.filter (fn x => not (Util.mem (x, ls2))) ls1,
 263      onlyInSecond = List.filter (fn x => not (Util.mem (x, ls1))) ls2}
 264
 265 fun listUsernames () = C.map (getDb ())
 266                              (fn [name] => C.stringFromSql name
 267                                | row => rowError ("listUsernames", row))
 268                              "SELECT name FROM WebUserActive ORDER BY name"
 269 fun usersInAfs () =
 270     let
 271         fun explore (dir, level, acc) =
 272             if level = 3 then
 273                 dir :: acc
 274             else
 275                 let
 276                     val dr = Posix.FileSys.opendir dir
 277
 278                     fun loop acc =
 279                         case Posix.FileSys.readdir dr of
 280                             NONE => acc
 281                           | SOME name =>
 282                             let
 283                                 val dir' = OS.Path.joinDirFile {dir = dir,
 284                                                                 file = name}
 285
 286                                 val acc = explore (dir', level+1, acc)
 287                             in
 288                                 loop acc
 289                             end
 290                 in
 291                     loop acc
 292                     before Posix.FileSys.closedir dr
 293                 end
 294
 295         val acc = explore ("/afs/hcoop.net/user", 0, [])
 296     in
 297         List.map OS.Path.file acc
 298     end
 299
 300 fun searchPaypal paypal =
 301     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 302                                   FROM WebUser
 303                                   WHERE paypal = ^(C.stringToSql paypal)
 304                                   ORDER BY name`)
 305
 306 fun searchCheckout checkout =
 307     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 308                                   FROM WebUser
 309                                   WHERE checkout = ^(C.stringToSql checkout)
 310                                   ORDER BY name`)
 311
 312 end