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             (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares
  47                                      FROM WebUserActive
  48                                      WHERE name=^(C.stringToSql name)`) of
  49                  NONE => raise Fail "User not found"
  50                | SOME r =>
  51                  let
  52                      val r = mkUserRow r
  53                  in
  54                      user := SOME r;
  55                      case C.oneOrNoRows c ($`SELECT ipaddr
  56                                                 FROM MemberApp
  57                                                 WHERE id = ^(C.intToSql (#app r))
  58                                                    AND ipaddr IS NOT NULL`) of
  59                          NONE =>
  60                          if Web.getParam "agree" = "on" then
  61                              (case Web.getCgi "REMOTE_ADDR" of
  62                                   NONE => raise Fail "REMOTE_ADDR not set"
  63                                 | SOME ra =>
  64                                   ignore (C.dml c ($`UPDATE MemberApp
  65                                                         SET ipaddr = ^(C.stringToSql ra),
  66                                                             applied = CURRENT_TIMESTAMP
  67                                                         WHERE id = ^(C.intToSql (#app r))`)))
  68                          else
  69                              raise NeedTos
  70                        | _ => ()
  71                  end)
  72     end
  73
  74 fun done () =
  75     let
  76         val db = getDb ()
  77     in
  78         C.dml db "COMMIT";
  79         close db
  80     end
  81
  82 fun getUser () = valOf (!user)
  83 fun getUserId () = #id (getUser ())
  84 fun getUserName () = #name (getUser ())
  85
  86 fun lookupUser id =
  87     mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares
  88                                       FROM WebUser
  89                                       WHERE id = ^(C.intToSql id)`))
  90
  91 fun listUsers () =
  92     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
  93                                   FROM WebUser
  94                                   ORDER BY name`)
  95
  96 fun nextSeq (db, seq) =
  97     case C.oneRow db ($`SELECT nextval('^(seq)')`) of
  98         [id] => C.intFromSql id
  99       | _ => raise Fail "Bad next sequence val"
 100
 101 fun addUser (name, rname, bal, app, shares) =
 102     let
 103         val db = getDb ()
 104         val id = nextSeq (db, "WebUserSeq")
 105     in
 106         C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares)
 107                     VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
 108                             CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`);
 109         id
 110     end
 111
 112 fun modUser (user : user) =
 113     let
 114         val db = getDb ()
 115     in
 116         ignore (C.dml db ($`UPDATE WebUser SET
 117                             name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
 118                                bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
 119                                shares = ^(C.intToSql (#shares user))
 120                             WHERE id = ^(C.intToSql (#id user))`))
 121     end
 122
 123 fun byPledge () =
 124     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
 125                                   FROM WebUser
 126                                   WHERE shares > 1
 127                                   ORDER BY shares DESC`)
 128
 129 fun deleteUser id =
 130     C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
 131
 132 fun validUsername name =
 133     size name <= 10
 134     andalso size name > 0
 135     andalso Char.isLower (String.sub (name, 0))
 136     andalso CharVector.all Char.isAlphaNum name
 137
 138 fun userNameToId name =
 139     case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
 140         SOME [id] => SOME (C.intFromSql id)
 141       | _ => NONE
 142
 143 fun dateString () =
 144     case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
 145         [d] => C.stringFromSql d
 146       | r => rowError ("dateString", r)
 147
 148 fun grandfatherUsers () =
 149     let
 150         val db = getDb ()
 151
 152         fun mkApp [id, name, rname] =
 153             let
 154                 val id = C.intFromSql id
 155                 val name = C.stringFromSql name
 156                 val rname = C.stringFromSql rname
 157
 158                 val aid = nextSeq (db, "MemberAppSeq")
 159             in
 160                 ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
 161                                                         passwd, status, applied, confirmed, decided, msg)
 162                                  VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
 163                                          NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
 164                                          'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
 165                                          CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
 166                 ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
 167             end
 168     in
 169         C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
 170     end
 171 end