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