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