[hcoop/zz_old/portal.git] / init.sml

structure Init :> INIT =
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

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, paypal : string option, checkout : string option }

val db = ref (NONE : C.conn option)
val user = ref (NONE : user option)

fun fromSql v =
    if C.isNull v then
	"NULL"
    else
	C.stringFromSql v

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, 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,
     paypal = nullableFromSql C.stringFromSql paypal,
     checkout = nullableFromSql C.stringFromSql checkout}
  | mkUserRow row = rowError ("user", row)

fun init () =
    let
	val _ = Util.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 =>
	    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
					                SET ipaddr = ^(C.stringToSql ra),
						          applied = CURRENT_TIMESTAMP
							WHERE id = ^(C.intToSql (#app r))`)))
			    else
				raise NeedTos
			  | _ => ()
		    end
	    end
    end

fun done () =
    let
	val db = getDb ()
    in
	C.dml db "COMMIT";
	close db
    end

fun getUser () = valOf (!user)
fun getUserId () = #id (getUser ())
fun getUserName () = #name (getUser ())

fun lookupUser id =
    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, 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, shares) =
    let
	val db = getDb ()
	val id = nextSeq (db, "WebUserSeq")
    in
	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

fun modUser (user : user) =
    let
	val db = getDb ()
    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)),
			       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 WebUser
				  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 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

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

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)

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
Commit	Line	Data
8d347a33	1	structure Init :> INIT =
	2	struct
	3
9d313c5f	4	open Util Sql Config
8d347a33	5	structure C = PgClient
8d347a33	6
20acb925	7	fun nullableFromSql f x =
	8	if C.isNull x then
	9	NONE
	10	else
	11	SOME (f x)
	12	fun nullableToSql f x =
	13	case x of
	14	NONE => "NULL"
	15	\| SOME x => f x
	16
8d347a33	17	exception Access of string
5146e435	18	exception NeedTos
8d347a33	19
9d313c5f	20	fun conn () = C.conn dbstring
8d347a33	21	val close = C.close
8d347a33	22
5146e435	23	type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
20acb925	24	app : int, shares : int, paypal : string option, checkout : string option }
8d347a33	25
	26	val db = ref (NONE : C.conn option)
	27	val user = ref (NONE : user option)
	28
369e1577	29	fun fromSql v =
	30	if C.isNull v then
	31	"NULL"
	32	else
	33	C.stringFromSql v
	34
	35	fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs)
	36
8d347a33	37	fun getDb () = valOf (!db)
8d347a33	38
20acb925	39	fun mkUserRow [id, name, rname, bal, joined, app, shares, paypal, checkout] =
8d347a33	40	{id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
5146e435	41	bal = C.intFromSql bal, joined = C.timestampFromSql joined,
20acb925	42	app = C.intFromSql app, shares = C.intFromSql shares,
	43	paypal = nullableFromSql C.stringFromSql paypal,
	44	checkout = nullableFromSql C.stringFromSql checkout}
369e1577	45	\| mkUserRow row = rowError ("user", row)
8d347a33	46
	47	fun init () =
	48	let
78304862	49	val _ = Util.init ()
78304862	50
8d347a33	51	val c = conn ()
8d347a33	52	in
5146e435	53	db := SOME c;
8d347a33	54	C.dml c "BEGIN";
	55	case Web.getCgi "REMOTE_USER" of
	56	NONE => raise Fail "Not logged in"
	57	\| SOME name =>
107a3ded	58	let
	59	val name =
	60	if String.isSuffix kerberosSuffix name then
	61	String.substring (name, 0, size name - size kerberosSuffix)
	62	else
	63	name
	64	in
20acb925	65	case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
107a3ded	66	FROM WebUserActive
	67	WHERE name=^(C.stringToSql name)`) of
	68	NONE => raise Fail "User not found"
	69	\| SOME r =>
	70	let
	71	val r = mkUserRow r
	72	in
	73	user := SOME r;
	74	case C.oneOrNoRows c ($`SELECT ipaddr
5146e435	75	FROM MemberApp
5146e435	76	WHERE id = ^(C.intToSql (#app r))
107a3ded	77	AND ipaddr IS NOT NULL`) of
	78	NONE =>
	79	if Web.getParam "agree" = "on" then
	80	(case Web.getCgi "REMOTE_ADDR" of
	81	NONE => raise Fail "REMOTE_ADDR not set"
	82	\| SOME ra =>
	83	ignore (C.dml c ($`UPDATE MemberApp
5146e435	84	SET ipaddr = ^(C.stringToSql ra),
107a3ded	85	applied = CURRENT_TIMESTAMP
	86	WHERE id = ^(C.intToSql (#app r))`)))
	87	else
	88	raise NeedTos
	89	\| _ => ()
	90	end
	91	end
8d347a33	92	end
	93
	94	fun done () =
	95	let
	96	val db = getDb ()
	97	in
	98	C.dml db "COMMIT";
	99	close db
	100	end
	101
	102	fun getUser () = valOf (!user)
	103	fun getUserId () = #id (getUser ())
	104	fun getUserName () = #name (getUser ())
	105
	106	fun lookupUser id =
20acb925	107	mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
8d347a33	108	FROM WebUser
	109	WHERE id = ^(C.intToSql id)`))
	110
	111	fun listUsers () =
20acb925	112	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
8d347a33	113	FROM WebUser
	114	ORDER BY name`)
	115
da3f3cbc	116	fun listActiveUsers () =
20acb925	117	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
da3f3cbc	118	FROM WebUserActive
	119	ORDER BY name`)
	120
8d347a33	121	fun nextSeq (db, seq) =
8d347a33	122	case C.oneRow db ($`SELECT nextval('^(seq)')`) of
369e1577	123	[id] => C.intFromSql id
8d347a33	124	\| _ => raise Fail "Bad next sequence val"
8d347a33	125
892e3ea1	126	fun addUser (name, rname, bal, app, shares) =
8d347a33	127	let
	128	val db = getDb ()
	129	val id = nextSeq (db, "WebUserSeq")
	130	in
6b8e4094	131	C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares, paypal, checkout)
892e3ea1	132	VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
6b8e4094	133	CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares),
7a02706f	134	(SELECT paypal FROM MemberApp WHERE id = ^(C.intToSql app)),
7a02706f	135	(SELECT checkout FROM MemberApp WHERE id = ^(C.intToSql app)))`);
369e1577	136	id
8d347a33	137	end
	138
	139	fun modUser (user : user) =
	140	let
	141	val db = getDb ()
	142	in
	143	ignore (C.dml db ($`UPDATE WebUser SET
	144	name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
892e3ea1	145	bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
20acb925	146	shares = ^(C.intToSql (#shares user)),
6ff384e9	147	paypal = ^(nullableToSql (C.stringToSql o Util.normEmail) (#paypal user)),
6ff384e9	148	checkout = ^(nullableToSql (C.stringToSql o Util.normEmail) (#checkout user))
8d347a33	149	WHERE id = ^(C.intToSql (#id user))`))
	150	end
	151
892e3ea1	152	fun byPledge () =
20acb925	153	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
892e3ea1	154	FROM WebUser
892e3ea1	155	WHERE shares > 1
6bb84252	156	ORDER BY shares DESC, name`)
892e3ea1	157
8d347a33	158	fun deleteUser id =
	159	C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
	160
	161	fun validUsername name =
	162	size name <= 10
09e213a2	163	andalso size name > 0
	164	andalso Char.isLower (String.sub (name, 0))
	165	andalso CharVector.all Char.isAlphaNum name
8d347a33	166
	167	fun userNameToId name =
	168	case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
	169	SOME [id] => SOME (C.intFromSql id)
	170	\| _ => NONE
	171
4b8df0b1	172	fun dateString () =
	173	case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
	174	[d] => C.stringFromSql d
	175	\| r => rowError ("dateString", r)
	176
5146e435	177	fun grandfatherUsers () =
	178	let
	179	val db = getDb ()
	180
	181	fun mkApp [id, name, rname] =
	182	let
	183	val id = C.intFromSql id
	184	val name = C.stringFromSql name
	185	val rname = C.stringFromSql rname
	186
	187	val aid = nextSeq (db, "MemberAppSeq")
	188	in
	189	ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
	190	passwd, status, applied, confirmed, decided, msg)
	191	VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
646dca75	192	NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
5146e435	193	'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
	194	CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
	195	ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
	196	end
	197	in
	198	C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
	199	end
8023de7b	200
	201	type node = {id : int, name : string, descr : string, debian : string}
	202
	203	fun mkNodeRow [id, name, descr, debian] =
	204	{id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr,
	205	debian = C.stringFromSql debian}
	206	\| mkNodeRow row = rowError ("node", row)
	207
	208	fun listNodes () =
	209	C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian
	210	FROM WebNode
	211	ORDER BY name`)
	212
	213	fun nodeName id =
	214	case C.oneRow (getDb ()) ($`SELECT name
	215	FROM WebNode
	216	WHERE id = ^(C.intToSql id)`) of
	217	[name] => C.stringFromSql name
	218	\| row => rowError ("nodeName", row)
	219
	220	fun nodeDebian id =
	221	case C.oneRow (getDb ()) ($`SELECT debian
	222	FROM WebNode
	223	WHERE id = ^(C.intToSql id)`) of
	224	[debian] => C.stringFromSql debian
	225	\| row => rowError ("nodeDebian", row)
	226
1ec55b98	227	fun explain e =
	228	case e of
	229	OS.SysErr (name, sop) =>
	230	"System error: " ^ name ^
	231	(case sop of
	232	NONE => ""
	233	\| SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr)
	234	\| _ => "Unknown"
	235
	236	fun tokens () =
	237	let
	238	val proc = Unix.execute ("/usr/bin/tokens", [])
	239	val inf = Unix.textInstreamOf proc
	240
	241	fun reader acc =
	242	case TextIO.inputLine inf of
	243	NONE => String.concat (rev acc)
	244	\| SOME s => reader (s :: acc)
	245	in
	246	reader []
	247	before (TextIO.closeIn inf;
	248	ignore (Unix.reap proc))
	249	end
	250
	251	fun tokensForked () =
	252	case Posix.Process.fork () of
	253	NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child";
	254	OS.Process.exit OS.Process.success)
	255	\| _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent")
	256
da3f3cbc	257	fun unmigratedUsers () =
	258	List.filter (fn user =>
	259	(ignore (Posix.SysDB.getpwnam (#name user));
	260	false)
	261	handle OS.SysErr _ => true) (listActiveUsers ())
	262
9fe97917	263	fun usersDiff (ls1, ls2) =
	264	{onlyInFirst = List.filter (fn x => not (Util.mem (x, ls2))) ls1,
	265	onlyInSecond = List.filter (fn x => not (Util.mem (x, ls1))) ls2}
	266
	267	fun listUsernames () = C.map (getDb ())
	268	(fn [name] => C.stringFromSql name
	269	\| row => rowError ("listUsernames", row))
	270	"SELECT name FROM WebUserActive ORDER BY name"
	271	fun usersInAfs () =
	272	let
	273	fun explore (dir, level, acc) =
	274	if level = 3 then
	275	dir :: acc
	276	else
	277	let
	278	val dr = Posix.FileSys.opendir dir
	279
	280	fun loop acc =
	281	case Posix.FileSys.readdir dr of
	282	NONE => acc
	283	\| SOME name =>
	284	let
	285	val dir' = OS.Path.joinDirFile {dir = dir,
	286	file = name}
	287
	288	val acc = explore (dir', level+1, acc)
	289	in
	290	loop acc
	291	end
	292	in
	293	loop acc
	294	before Posix.FileSys.closedir dr
	295	end
	296
	297	val acc = explore ("/afs/hcoop.net/user", 0, [])
	298	in
	299	List.map OS.Path.file acc
	300	end
	301
20acb925	302	fun searchPaypal paypal =
	303	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
	304	FROM WebUser
6ff384e9	305	WHERE paypal = ^(C.stringToSql (normEmail paypal))
20acb925	306	ORDER BY name`)
	307
	308	fun searchCheckout checkout =
	309	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
	310	FROM WebUser
6ff384e9	311	WHERE checkout = ^(C.stringToSql (normEmail checkout))
20acb925	312	ORDER BY name`)
20acb925	313
646dca75	314	end