init.sml

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