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