structure Init :> INIT =
struct
-open Util Sql
+open Util Sql Config
structure C = PgClient
exception Access of string
+exception NeedTos
-val urlPrefix = "http://users.hcoop.net/portal/"
-
-fun conn () = C.conn "dbname='hcoop'"
+fun conn () = C.conn dbstring
val close = C.close
-type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp}
+type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
+ app : int, shares : int}
val db = ref (NONE : C.conn option)
val user = ref (NONE : user option)
fun getDb () = valOf (!db)
-fun mkUserRow [id, name, rname, bal, joined] =
+fun mkUserRow [id, name, rname, bal, joined, app, shares] =
{id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
- bal = C.intFromSql bal, joined = C.timestampFromSql joined}
+ bal = C.intFromSql bal, joined = C.timestampFromSql joined,
+ app = C.intFromSql app, shares = C.intFromSql shares}
| mkUserRow row = rowError ("user", row)
fun init () =
val c = conn ()
in
+ db := SOME c;
C.dml c "BEGIN";
case Web.getCgi "REMOTE_USER" of
NONE => raise Fail "Not logged in"
| SOME name =>
- (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined
- FROM WebUser
+ (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares
+ FROM WebUserActive
WHERE name=^(C.stringToSql name)`) of
NONE => raise Fail "User not found"
- | SOME r => user := SOME (mkUserRow r));
- db := SOME c
+ | SOME r =>
+ let
+ val r = mkUserRow r
+ in
+ user := SOME r;
+ case C.oneOrNoRows c ($`SELECT ipaddr
+ FROM MemberApp
+ WHERE id = ^(C.intToSql (#app r))
+ AND ipaddr IS NOT NULL`) of
+ NONE =>
+ if Web.getParam "agree" = "on" then
+ (case Web.getCgi "REMOTE_ADDR" of
+ NONE => raise Fail "REMOTE_ADDR not set"
+ | SOME ra =>
+ ignore (C.dml c ($`UPDATE MemberApp
+ SET ipaddr = ^(C.stringToSql ra),
+ applied = CURRENT_TIMESTAMP
+ WHERE id = ^(C.intToSql (#app r))`)))
+ else
+ raise NeedTos
+ | _ => ()
+ end)
end
fun done () =
fun getUserName () = #name (getUser ())
fun lookupUser id =
- mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined
+ mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares
FROM WebUser
WHERE id = ^(C.intToSql id)`))
fun listUsers () =
- C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined
+ C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
FROM WebUser
ORDER BY name`)
[id] => C.intFromSql id
| _ => raise Fail "Bad next sequence val"
-fun addUser (name, rname, bal) =
+fun addUser (name, rname, bal, app, shares) =
let
val db = getDb ()
val id = nextSeq (db, "WebUserSeq")
in
- C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined)
- VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP)`);
+ C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares)
+ VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
+ CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`);
id
end
in
ignore (C.dml db ($`UPDATE WebUser SET
name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
- bal = ^(C.intToSql (#bal user))
+ bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
+ shares = ^(C.intToSql (#shares user))
WHERE id = ^(C.intToSql (#id user))`))
end
+fun byPledge () =
+ C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
+ FROM WebUser
+ WHERE shares > 1
+ ORDER BY shares DESC`)
+
fun deleteUser id =
C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
fun validUsername name =
size name <= 10
- andalso CharVector.all Char.isAlpha name
+ andalso size name > 0
+ andalso Char.isLower (String.sub (name, 0))
+ andalso CharVector.all Char.isAlphaNum name
fun userNameToId name =
case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
SOME [id] => SOME (C.intFromSql id)
| _ => NONE
-end
\ No newline at end of file
+fun dateString () =
+ case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
+ [d] => C.stringFromSql d
+ | r => rowError ("dateString", r)
+
+fun grandfatherUsers () =
+ let
+ val db = getDb ()
+
+ fun mkApp [id, name, rname] =
+ let
+ val id = C.intFromSql id
+ val name = C.stringFromSql name
+ val rname = C.stringFromSql rname
+
+ val aid = nextSeq (db, "MemberAppSeq")
+ in
+ ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
+ passwd, status, applied, confirmed, decided, msg)
+ VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
+ NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
+ 'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
+ CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
+ ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
+ end
+ in
+ C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
+ end
+end