X-Git-Url: https://git.hcoop.net/hcoop/portal.git/blobdiff_plain/93f77ca7c0fbfefe5eaf130c360cd1d112f40d52..80da0f7a4c68eb1c5112fe36cb30ccfd7baa9067:/init.sml

diff --git a/init.sml b/init.sml
index 0d1a920..a44bc35 100644
--- a/init.sml
+++ b/init.sml
@@ -1,21 +1,27 @@
 structure Init :> INIT =
 struct
 
-open Util Sql
+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
 
-val urlPrefix = "https://members.hcoop.net/portal/"
-val emailSuffix = "@new.hcoop.net"
-val boardEmail = "board" ^ emailSuffix
-
-fun conn () = C.conn "dbname='hcoop_hcoop'"
+fun conn () = C.conn dbstring
 val close = C.close
 
 type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
-	     app : int}
+	     app : int, shares : int, paypal : string option, checkout : string option }
 
 val db = ref (NONE : C.conn option)
 val user = ref (NONE : user option)
@@ -30,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] =
+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}
+     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 () =
@@ -47,32 +55,40 @@ fun init () =
 	case Web.getCgi "REMOTE_USER" of
 	    NONE => raise Fail "Not logged in"
 	  | SOME name =>
-	    (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app
-  				     FROM WebUser
-				     WHERE name=^(C.stringToSql name)`) of
-		 NONE => raise Fail "User not found"
-	       | SOME r =>
-		 let
-		     val r = mkUserRow r
-		 in
-		     user := SOME r;
-		     case C.oneOrNoRows c ($`SELECT ipaddr
+	    let
+		val name =
+		    if String.isSuffix kerberosSuffix name then
+			String.substring (name, 0, size name - size kerberosSuffix)
+		    else
+			name
+	    in
+		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"
+		  | 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
+								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)
+						          applied = CURRENT_TIMESTAMP
+							WHERE id = ^(C.intToSql (#app r))`)))
+			    else
+				raise NeedTos
+			  | _ => ()
+		    end
+	    end
     end
 
 fun done () =
@@ -88,27 +104,35 @@ fun getUserId () = #id (getUser ())
 fun getUserName () = #name (getUser ())
 
 fun lookupUser id =
-    mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app
+    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
+    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
       | _ => raise Fail "Bad next sequence val"
 
-fun addUser (name, rname, bal, app) =
+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, app)
-		    VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP, ^(C.intToSql app))`);
+	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),
+			    (SELECT paypal FROM MemberApp WHERE id = ^(C.intToSql app)),
+			    (SELECT checkout FROM MemberApp WHERE id = ^(C.intToSql app)))`);
 	id
     end
 
@@ -118,16 +142,27 @@ 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)), app = ^(C.intToSql (#app user))
+			       bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app 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, paypal, checkout
+			          FROM WebUserPaying
+				  WHERE shares > 1
+			          ORDER BY shares DESC, name`)
+
 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
+    size name <= 12
+    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
@@ -139,27 +174,118 @@ fun dateString () =
 	[d] => C.stringFromSql d
       | r => rowError ("dateString", r)
 
-fun grandfatherUsers () =
+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
+                                  WHERE id IN (SELECT id FROM ActiveWebNode)
+			          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)
+
+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 db = getDb ()
+	val proc = Unix.execute ("/usr/bin/tokens", [])
+	val inf = Unix.textInstreamOf proc
 
-	fun mkApp [id, name, rname] =
-	    let
-		val id = C.intFromSql id
-		val name = C.stringFromSql name
-		val rname = C.stringFromSql rname
+	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
 
-		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
+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 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
-	C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
+	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