X-Git-Url: https://git.hcoop.net/hcoop/portal.git/blobdiff_plain/59eb5381735d29cc1e985cf8bc8a328640fede44..80da0f7a4c68eb1c5112fe36cb30ccfd7baa9067:/init.sml diff --git a/init.sml b/init.sml index c5f5fa9..a44bc35 100644 --- a/init.sml +++ b/init.sml @@ -4,6 +4,16 @@ struct open Util Sql Config structure C = PgClient +fun nullableFromSql f x = + if C.isNull x then + NONE + else + SOME (f x) +fun nullableToSql f x = + case x of + NONE => "NULL" + | SOME x => f x + exception Access of string exception NeedTos @@ -11,7 +21,7 @@ fun conn () = C.conn dbstring val close = C.close type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp, - app : int, shares : int} + app : int, shares : int, paypal : string option, checkout : string option } val db = ref (NONE : C.conn option) val user = ref (NONE : user option) @@ -26,10 +36,12 @@ fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs fun getDb () = valOf (!db) -fun mkUserRow [id, name, rname, bal, joined, app, shares] = +fun mkUserRow [id, name, rname, bal, joined, app, shares, paypal, checkout] = {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname, bal = C.intFromSql bal, joined = C.timestampFromSql joined, - app = C.intFromSql app, shares = C.intFromSql shares} + app = C.intFromSql app, shares = C.intFromSql shares, + paypal = nullableFromSql C.stringFromSql paypal, + checkout = nullableFromSql C.stringFromSql checkout} | mkUserRow row = rowError ("user", row) fun init () = @@ -50,7 +62,7 @@ fun init () = else name in - case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares + case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout FROM WebUserActive WHERE name=^(C.stringToSql name)`) of NONE => raise Fail "User not found" @@ -92,17 +104,17 @@ fun getUserId () = #id (getUser ()) fun getUserName () = #name (getUser ()) fun lookupUser id = - mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares + mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout FROM WebUser WHERE id = ^(C.intToSql id)`)) fun listUsers () = - C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares + C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout FROM WebUser ORDER BY name`) fun listActiveUsers () = - C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares + C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout FROM WebUserActive ORDER BY name`) @@ -116,9 +128,11 @@ fun addUser (name, rname, bal, app, shares) = val db = getDb () val id = nextSeq (db, "WebUserSeq") in - C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares) + C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares, paypal, checkout) VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), - CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`); + CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares), + (SELECT paypal FROM MemberApp WHERE id = ^(C.intToSql app)), + (SELECT checkout FROM MemberApp WHERE id = ^(C.intToSql app)))`); id end @@ -129,13 +143,15 @@ fun modUser (user : user) = ignore (C.dml db ($`UPDATE WebUser SET name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)), bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)), - shares = ^(C.intToSql (#shares user)) + shares = ^(C.intToSql (#shares user)), + paypal = ^(nullableToSql (C.stringToSql o Util.normEmail) (#paypal user)), + checkout = ^(nullableToSql (C.stringToSql o Util.normEmail) (#checkout user)) WHERE id = ^(C.intToSql (#id user))`)) end fun byPledge () = - C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares - FROM WebUser + C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout + FROM WebUserPaying WHERE shares > 1 ORDER BY shares DESC, name`) @@ -143,7 +159,7 @@ fun deleteUser id = C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`) fun validUsername name = - size name <= 10 + size name <= 12 andalso size name > 0 andalso Char.isLower (String.sub (name, 0)) andalso CharVector.all Char.isAlphaNum name @@ -158,30 +174,6 @@ fun dateString () = [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 - type node = {id : int, name : string, descr : string, debian : string} fun mkNodeRow [id, name, descr, debian] = @@ -192,6 +184,7 @@ fun mkNodeRow [id, name, descr, debian] = fun listNodes () = C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian FROM WebNode + WHERE id IN (SELECT id FROM ActiveWebNode) ORDER BY name`) fun nodeName id = @@ -238,12 +231,6 @@ fun tokensForked () = OS.Process.exit OS.Process.success) | _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent") -fun unmigratedUsers () = - List.filter (fn user => - (ignore (Posix.SysDB.getpwnam (#name user)); - false) - handle OS.SysErr _ => true) (listActiveUsers ()) - fun usersDiff (ls1, ls2) = {onlyInFirst = List.filter (fn x => not (Util.mem (x, ls2))) ls1, onlyInSecond = List.filter (fn x => not (Util.mem (x, ls1))) ls2} @@ -283,4 +270,22 @@ fun usersInAfs () = List.map OS.Path.file acc end +fun searchPaypal paypal = + C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout + FROM WebUser + WHERE paypal = ^(C.stringToSql (normEmail paypal)) + ORDER BY name`) + +fun searchCheckout checkout = + C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout + FROM WebUser + WHERE checkout = ^(C.stringToSql (normEmail checkout)) + ORDER BY name`) + +fun searchRealName realname = + C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout + FROM WebUser + WHERE rname ILIKE (^(C.stringToSql "%") || trim (both ^(C.stringToSql " ") from ^(C.stringToSql realname)) || ^(C.stringToSql "%")) + ORDER BY name`) + end