X-Git-Url: https://git.hcoop.net/hcoop/zz_old/portal.git/blobdiff_plain/4b8df0b1e0ef6900d3d78b7169cb5d662ed6c657..66db411c02f88151a7a93e6e9f70345cd536fe4c:/init.sml diff --git a/init.sml b/init.sml index 12092b4..d6aae9c 100644 --- a/init.sml +++ b/init.sml @@ -1,18 +1,17 @@ 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/" -val boardEmail = "board.fake@hcoop.net" - -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) @@ -27,9 +26,10 @@ fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs 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 () = @@ -38,16 +38,37 @@ 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 () = @@ -63,12 +84,12 @@ fun getUserId () = #id (getUser ()) 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`) @@ -77,13 +98,14 @@ fun nextSeq (db, seq) = [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 @@ -93,16 +115,25 @@ fun modUser (user : user) = 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 @@ -114,4 +145,54 @@ fun dateString () = [d] => C.stringFromSql d | r => rowError ("dateString", r) -end \ No newline at end of file +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 + +type node = {id : int, name : string, descr : string, debian : string} + +fun mkNodeRow [id, name, descr, debian] = + {id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr, + debian = C.stringFromSql debian} + | mkNodeRow row = rowError ("node", row) + +fun listNodes () = + C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian + FROM WebNode + ORDER BY name`) + +fun nodeName id = + case C.oneRow (getDb ()) ($`SELECT name + FROM WebNode + WHERE id = ^(C.intToSql id)`) of + [name] => C.stringFromSql name + | row => rowError ("nodeName", row) + +fun nodeDebian id = + case C.oneRow (getDb ()) ($`SELECT debian + FROM WebNode + WHERE id = ^(C.intToSql id)`) of + [debian] => C.stringFromSql debian + | row => rowError ("nodeDebian", row) + +end