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 nextSeq (db, seq) =
 105     case C.oneRow db ($`SELECT nextval('^(seq)')`) of
 106         [id] => C.intFromSql id
 107       | _ => raise Fail "Bad next sequence val"
 108
 109 fun addUser (name, rname, bal, app, shares) =
 110     let
 111         val db = getDb ()
 112         val id = nextSeq (db, "WebUserSeq")
 113     in
 114         C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares)
 115                     VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
 116                             CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`);
 117         id
 118     end
 119
 120 fun modUser (user : user) =
 121     let
 122         val db = getDb ()
 123     in
 124         ignore (C.dml db ($`UPDATE WebUser SET
 125                             name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
 126                                bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
 127                                shares = ^(C.intToSql (#shares user))
 128                             WHERE id = ^(C.intToSql (#id user))`))
 129     end
 130
 131 fun byPledge () =
 132     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
 133                                   FROM WebUser
 134                                   WHERE shares > 1
 135                                   ORDER BY shares DESC, name`)
 136
 137 fun deleteUser id =
 138     C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
 139
 140 fun validUsername name =
 141     size name <= 10
 142     andalso size name > 0
 143     andalso Char.isLower (String.sub (name, 0))
 144     andalso CharVector.all Char.isAlphaNum name
 145
 146 fun userNameToId name =
 147     case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
 148         SOME [id] => SOME (C.intFromSql id)
 149       | _ => NONE
 150
 151 fun dateString () =
 152     case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
 153         [d] => C.stringFromSql d
 154       | r => rowError ("dateString", r)
 155
 156 fun grandfatherUsers () =
 157     let
 158         val db = getDb ()
 159
 160         fun mkApp [id, name, rname] =
 161             let
 162                 val id = C.intFromSql id
 163                 val name = C.stringFromSql name
 164                 val rname = C.stringFromSql rname
 165
 166                 val aid = nextSeq (db, "MemberAppSeq")
 167             in
 168                 ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
 169                                                         passwd, status, applied, confirmed, decided, msg)
 170                                  VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
 171                                          NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
 172                                          'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
 173                                          CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
 174                 ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
 175             end
 176     in
 177         C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
 178     end
 179
 180 type node = {id : int, name : string, descr : string, debian : string}
 181
 182 fun mkNodeRow [id, name, descr, debian] =
 183     {id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr,
 184      debian = C.stringFromSql debian}
 185   | mkNodeRow row = rowError ("node", row)
 186
 187 fun listNodes () =
 188     C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian
 189                                   FROM WebNode
 190                                   ORDER BY name`)
 191
 192 fun nodeName id =
 193     case C.oneRow (getDb ()) ($`SELECT name
 194                                 FROM WebNode
 195                                 WHERE id = ^(C.intToSql id)`) of
 196         [name] => C.stringFromSql name
 197       | row => rowError ("nodeName", row)
 198
 199 fun nodeDebian id =
 200     case C.oneRow (getDb ()) ($`SELECT debian
 201                                 FROM WebNode
 202                                 WHERE id = ^(C.intToSql id)`) of
 203         [debian] => C.stringFromSql debian
 204       | row => rowError ("nodeDebian", row)
 205
 206 end