[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)
		    VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
			    CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`);
	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 (#paypal user)),
			       checkout = ^(nullableToSql C.stringToSql (#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 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 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
892e3ea1	131	C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares)
	132	VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
	133	CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares))`);
369e1577	134	id
8d347a33	135	end
	136
	137	fun modUser (user : user) =
	138	let
	139	val db = getDb ()
	140	in
	141	ignore (C.dml db ($`UPDATE WebUser SET
	142	name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
892e3ea1	143	bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
20acb925	144	shares = ^(C.intToSql (#shares user)),
	145	paypal = ^(nullableToSql C.stringToSql (#paypal user)),
	146	checkout = ^(nullableToSql C.stringToSql (#checkout user))
8d347a33	147	WHERE id = ^(C.intToSql (#id user))`))
	148	end
	149
892e3ea1	150	fun byPledge () =
20acb925	151	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
892e3ea1	152	FROM WebUser
892e3ea1	153	WHERE shares > 1
6bb84252	154	ORDER BY shares DESC, name`)
892e3ea1	155
8d347a33	156	fun deleteUser id =
	157	C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
	158
	159	fun validUsername name =
	160	size name <= 10
09e213a2	161	andalso size name > 0
	162	andalso Char.isLower (String.sub (name, 0))
	163	andalso CharVector.all Char.isAlphaNum name
8d347a33	164
	165	fun userNameToId name =
	166	case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
	167	SOME [id] => SOME (C.intFromSql id)
	168	\| _ => NONE
	169
4b8df0b1	170	fun dateString () =
	171	case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
	172	[d] => C.stringFromSql d
	173	\| r => rowError ("dateString", r)
	174
5146e435	175	fun grandfatherUsers () =
	176	let
	177	val db = getDb ()
	178
	179	fun mkApp [id, name, rname] =
	180	let
	181	val id = C.intFromSql id
	182	val name = C.stringFromSql name
	183	val rname = C.stringFromSql rname
	184
	185	val aid = nextSeq (db, "MemberAppSeq")
	186	in
	187	ignore (C.dml db ($`INSERT INTO MemberApp (id, name, rname, gname, email, forward, uses, other,
	188	passwd, status, applied, confirmed, decided, msg)
	189	VALUES (^(C.intToSql aid), ^(C.stringToSql name), ^(C.stringToSql rname),
646dca75	190	NULL, '^name^(emailSuffix)', FALSE, 'GRANDFATHERED', 'GRANDFATHERED',
5146e435	191	'GRANDFATHERED', 4, CURRENT_TIMESTAMP, CURRENT_TIMESTAMP,
	192	CURRENT_TIMESTAMP, 'GRANDFATHERED')`));
	193	ignore (C.dml db ($`UPDATE WebUser SET app = ^(C.intToSql aid) WHERE id = ^(C.intToSql id)`))
	194	end
	195	in
	196	C.app db mkApp "SELECT id, name, rname FROM WebUser WHERE app IS NULL"
	197	end
8023de7b	198
	199	type node = {id : int, name : string, descr : string, debian : string}
	200
	201	fun mkNodeRow [id, name, descr, debian] =
	202	{id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr,
	203	debian = C.stringFromSql debian}
	204	\| mkNodeRow row = rowError ("node", row)
	205
	206	fun listNodes () =
	207	C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian
	208	FROM WebNode
	209	ORDER BY name`)
	210
	211	fun nodeName id =
	212	case C.oneRow (getDb ()) ($`SELECT name
	213	FROM WebNode
	214	WHERE id = ^(C.intToSql id)`) of
	215	[name] => C.stringFromSql name
	216	\| row => rowError ("nodeName", row)
	217
	218	fun nodeDebian id =
	219	case C.oneRow (getDb ()) ($`SELECT debian
	220	FROM WebNode
	221	WHERE id = ^(C.intToSql id)`) of
	222	[debian] => C.stringFromSql debian
	223	\| row => rowError ("nodeDebian", row)
	224
1ec55b98	225	fun explain e =
	226	case e of
	227	OS.SysErr (name, sop) =>
	228	"System error: " ^ name ^
	229	(case sop of
	230	NONE => ""
	231	\| SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr)
	232	\| _ => "Unknown"
	233
	234	fun tokens () =
	235	let
	236	val proc = Unix.execute ("/usr/bin/tokens", [])
	237	val inf = Unix.textInstreamOf proc
	238
	239	fun reader acc =
	240	case TextIO.inputLine inf of
	241	NONE => String.concat (rev acc)
	242	\| SOME s => reader (s :: acc)
	243	in
	244	reader []
	245	before (TextIO.closeIn inf;
	246	ignore (Unix.reap proc))
	247	end
	248
	249	fun tokensForked () =
	250	case Posix.Process.fork () of
	251	NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child";
	252	OS.Process.exit OS.Process.success)
	253	\| _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent")
	254
da3f3cbc	255	fun unmigratedUsers () =
	256	List.filter (fn user =>
	257	(ignore (Posix.SysDB.getpwnam (#name user));
	258	false)
	259	handle OS.SysErr _ => true) (listActiveUsers ())
	260
9fe97917	261	fun usersDiff (ls1, ls2) =
	262	{onlyInFirst = List.filter (fn x => not (Util.mem (x, ls2))) ls1,
	263	onlyInSecond = List.filter (fn x => not (Util.mem (x, ls1))) ls2}
	264
	265	fun listUsernames () = C.map (getDb ())
	266	(fn [name] => C.stringFromSql name
	267	\| row => rowError ("listUsernames", row))
	268	"SELECT name FROM WebUserActive ORDER BY name"
	269	fun usersInAfs () =
	270	let
	271	fun explore (dir, level, acc) =
	272	if level = 3 then
	273	dir :: acc
	274	else
	275	let
	276	val dr = Posix.FileSys.opendir dir
	277
	278	fun loop acc =
	279	case Posix.FileSys.readdir dr of
	280	NONE => acc
	281	\| SOME name =>
	282	let
	283	val dir' = OS.Path.joinDirFile {dir = dir,
	284	file = name}
	285
	286	val acc = explore (dir', level+1, acc)
	287	in
	288	loop acc
	289	end
	290	in
	291	loop acc
	292	before Posix.FileSys.closedir dr
	293	end
	294
	295	val acc = explore ("/afs/hcoop.net/user", 0, [])
	296	in
	297	List.map OS.Path.file acc
	298	end
	299
20acb925	300	fun searchPaypal paypal =
	301	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
	302	FROM WebUser
	303	WHERE paypal = ^(C.stringToSql paypal)
	304	ORDER BY name`)
	305
	306	fun searchCheckout checkout =
	307	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
	308	FROM WebUser
	309	WHERE checkout = ^(C.stringToSql checkout)
	310	ORDER BY name`)
	311
646dca75	312	end