X-Git-Url: http://git.hcoop.net/bpt/portal.git/blobdiff_plain/d90048bddd04114d5ff1015bd9185ec1759d4ae8..64ec9551fc56c42188e195cbbe24c79ad18b293f:/init.sml

diff --git a/init.sml b/init.sml
index 4d55c90..ba3b2bf 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,15 +104,20 @@ 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, paypal, checkout
+			          FROM WebUserActive
+			          ORDER BY name`)
+
 fun nextSeq (db, seq) =
     case C.oneRow db ($`SELECT nextval('^(seq)')`) of
 	[id] => C.intFromSql id
@@ -111,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
 
@@ -124,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`)
 
@@ -138,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
@@ -203,4 +224,91 @@ fun nodeDebian id =
 	[debian] => C.stringFromSql debian
       | row => rowError ("nodeDebian", row)
 
+fun explain e =
+    case e of
+	OS.SysErr (name, sop) =>
+	"System error: " ^ name ^
+	(case sop of
+	     NONE => ""
+	   | SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr)
+      | _ => "Unknown"
+
+fun tokens () =
+    let
+	val proc = Unix.execute ("/usr/bin/tokens", [])
+	val inf = Unix.textInstreamOf proc
+
+	fun reader acc =
+	    case TextIO.inputLine inf of
+		NONE => String.concat (rev acc)
+	      | SOME s => reader (s :: acc)
+    in
+	reader []
+	before (TextIO.closeIn inf;
+		ignore (Unix.reap proc))
+    end
+
+fun tokensForked () =
+    case Posix.Process.fork () of
+	NONE =>	(OS.Process.system "/usr/bin/tokens >/tmp/tokens.child";
+		 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}
+
+fun listUsernames () = C.map (getDb ())
+			     (fn [name] => C.stringFromSql name
+			       | row => rowError ("listUsernames", row))
+			     "SELECT name FROM WebUserActive ORDER BY name"
+fun usersInAfs () =
+    let
+	fun explore (dir, level, acc) =
+	    if level = 3 then
+		dir :: acc
+	    else
+		let
+		    val dr = Posix.FileSys.opendir dir
+
+		    fun loop acc =
+			case Posix.FileSys.readdir dr of
+			    NONE => acc
+			  | SOME name =>
+			    let
+				val dir' = OS.Path.joinDirFile {dir = dir,
+								file = name}
+
+				val acc = explore (dir', level+1, acc)
+			    in
+				loop acc
+			    end
+		in
+		    loop acc
+		    before Posix.FileSys.closedir dr
+		end
+
+	val acc = explore ("/afs/hcoop.net/user", 0, [])
+    in
+	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`)
+
 end