init.sml

   1 structure Init :> INIT =
   2 struct
   3
   4 open Util Sql
   5 structure C = PgClient
   6
   7 exception Access of string
   8 exception NeedTos
   9
  10 val urlPrefix = "http://users.hcoop.net/portal/"
  11 val boardEmail = "board.fake@hcoop.net"
  12
  13 fun conn () = C.conn "dbname='hcoop'"
  14 val close = C.close
  15
  16 type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
  17              app : int}
  18
  19 val db = ref (NONE : C.conn option)
  20 val user = ref (NONE : user option)
  21
  22 fun fromSql v =
  23     if C.isNull v then
  24         "NULL"
  25     else
  26         C.stringFromSql v
  27
  28 fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs)
  29
  30 fun getDb () = valOf (!db)
  31
  32 fun mkUserRow [id, name, rname, bal, joined, app] =
  33     {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
  34      bal = C.intFromSql bal, joined = C.timestampFromSql joined,
  35      app = C.intFromSql app}
  36   | mkUserRow row = rowError ("user", row)
  37
  38 fun init () =
  39     let
  40         val _ = Util.init ()
  41
  42         val c = conn ()
  43     in
  44         db := SOME c;
  45         C.dml c "BEGIN";
  46         case Web.getCgi "REMOTE_USER" of
  47             NONE => raise Fail "Not logged in"
  48           | SOME name =>
  49             (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app
  50                                      FROM WebUser
  51                                      WHERE name=^(C.stringToSql name)`) of
  52                  NONE => raise Fail "User not found"
  53                | SOME r =>
  54                  let
  55                      val r = mkUserRow r
  56                  in
  57                      user := SOME r;
  58                      case C.oneOrNoRows c ($`SELECT ipaddr
  59                                                 FROM MemberApp
  60                                                 WHERE id = ^(C.intToSql (#app r))
  61                                                    AND ipaddr IS NOT NULL`) of
  62                          NONE =>
  63                          if Web.getParam "agree" = "on" then
  64                              (case Web.getCgi "REMOTE_ADDR" of
  65                                   NONE => raise Fail "REMOTE_ADDR not set"
  66                                 | SOME ra =>
  67                                   ignore (C.dml c ($`UPDATE MemberApp
  68                                                         SET ipaddr = ^(C.stringToSql ra),
  69                                                             applied = CURRENT_TIMESTAMP
  70                                                         WHERE id = ^(C.intToSql (#app r))`)))
  71                          else
  72                              raise NeedTos
  73                        | _ => ()
  74                  end)
  75     end
  76
  77 fun done () =
  78     let
  79         val db = getDb ()
  80     in
  81         C.dml db "COMMIT";
  82         close db
  83     end
  84
  85 fun getUser () = valOf (!user)
  86 fun getUserId () = #id (getUser ())
  87 fun getUserName () = #name (getUser ())
  88
  89 fun lookupUser id =
  90     mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app
  91                                       FROM WebUser
  92                                       WHERE id = ^(C.intToSql id)`))
  93
  94 fun listUsers () =
  95     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app
  96                                   FROM WebUser
  97                                   ORDER BY name`)
  98
  99 fun nextSeq (db, seq) =
 100     case C.oneRow db ($`SELECT nextval('^(seq)')`) of
 101         [id] => C.intFromSql id
 102       | _ => raise Fail "Bad next sequence val"
 103
 104 fun addUser (name, rname, bal, app) =
 105     let
 106         val db = getDb ()
 107         val id = nextSeq (db, "WebUserSeq")
 108     in
 109         C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app)
 110                     VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP, ^(C.intToSql app))`);
 111         id
 112     end
 113
 114 fun modUser (user : user) =
 115     let
 116         val db = getDb ()
 117     in
 118         ignore (C.dml db ($`UPDATE WebUser SET
 119                             name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
 120                                bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user))
 121                             WHERE id = ^(C.intToSql (#id user))`))
 122     end
 123
 124 fun deleteUser id =
 125     C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
 126
 127 fun validUsername name =
 128     size name <= 10
 129     andalso CharVector.all Char.isAlpha name
 130
 131 fun userNameToId name =
 132     case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
 133         SOME [id] => SOME (C.intFromSql id)
 134       | _ => NONE
 135
 136 fun dateString () =
 137     case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
 138         [d] => C.stringFromSql d
 139       | r => rowError ("dateString", r)
 140
 141 fun grandfatherUsers () =
 142     let
 143         val db = getDb ()
 144
 145         fun mkApp [id, name, rname] =
 146             let
 147                 val id = C.intFromSql id
 148                 val name = C.stringFromSql name
 149                 val rname = C.stringFromSql rname
 150
 151                 val aid = nextSeq (db, "MemberAppSeq")
 152             in
 153                 ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
 154                                                         passwd, status, applied, confirmed, decided, msg)
 155                                  VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
 156                                          NULL, '^name@hcoop.net', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
 157                                          'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
 158                                          CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
 159                 ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
 160             end
 161     in
 162         C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
 163     end
 164 end