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

structure Init :> INIT =
struct

open Util Sql Config
structure C = PgClient

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}

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] =
    {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}
  | 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
  				        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
				      FROM WebUser
			     	      WHERE id = ^(C.intToSql id)`))

fun listUsers () =
    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
			          FROM WebUser
			          ORDER BY name`)

fun listActiveUsers () =
    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
			          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))
			    WHERE id = ^(C.intToSql (#id user))`))
    end

fun byPledge () =
    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares
			          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

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