[hcoop/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 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 <= 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
	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)

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 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 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`)

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
Commit	Line	Data
208e2cbc AC	1	structure Init :> INIT =
	2	struct
	3
dda99898	4	open Util Sql Config
208e2cbc AC	5	structure C = PgClient
208e2cbc AC	6
d5f8418b AC	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
208e2cbc	17	exception Access of string
f3f3ad24	18	exception NeedTos
208e2cbc	19
dda99898	20	fun conn () = C.conn dbstring
208e2cbc AC	21	val close = C.close
208e2cbc AC	22
f3f3ad24	23	type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp,
d5f8418b	24	app : int, shares : int, paypal : string option, checkout : string option }
208e2cbc AC	25
	26	val db = ref (NONE : C.conn option)
	27	val user = ref (NONE : user option)
	28
ee587f7f AC	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
208e2cbc AC	37	fun getDb () = valOf (!db)
208e2cbc AC	38
d5f8418b	39	fun mkUserRow [id, name, rname, bal, joined, app, shares, paypal, checkout] =
208e2cbc	40	{id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
f3f3ad24	41	bal = C.intFromSql bal, joined = C.timestampFromSql joined,
d5f8418b AC	42	app = C.intFromSql app, shares = C.intFromSql shares,
	43	paypal = nullableFromSql C.stringFromSql paypal,
	44	checkout = nullableFromSql C.stringFromSql checkout}
ee587f7f	45	\| mkUserRow row = rowError ("user", row)
208e2cbc AC	46
	47	fun init () =
	48	let
9d1c0e98 AC	49	val _ = Util.init ()
9d1c0e98 AC	50
208e2cbc AC	51	val c = conn ()
208e2cbc AC	52	in
f3f3ad24	53	db := SOME c;
208e2cbc AC	54	C.dml c "BEGIN";
	55	case Web.getCgi "REMOTE_USER" of
	56	NONE => raise Fail "Not logged in"
	57	\| SOME name =>
f660f7dd AC	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
d5f8418b	65	case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
f660f7dd AC	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
f3f3ad24 AC	75	FROM MemberApp
f3f3ad24 AC	76	WHERE id = ^(C.intToSql (#app r))
f660f7dd AC	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
f3f3ad24	84	SET ipaddr = ^(C.stringToSql ra),
f660f7dd AC	85	applied = CURRENT_TIMESTAMP
	86	WHERE id = ^(C.intToSql (#app r))`)))
	87	else
	88	raise NeedTos
	89	\| _ => ()
	90	end
	91	end
208e2cbc AC	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 =
d5f8418b	107	mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
208e2cbc AC	108	FROM WebUser
	109	WHERE id = ^(C.intToSql id)`))
	110
	111	fun listUsers () =
d5f8418b	112	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
208e2cbc AC	113	FROM WebUser
	114	ORDER BY name`)
	115
60754922	116	fun listActiveUsers () =
d5f8418b	117	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
60754922 AC	118	FROM WebUserActive
	119	ORDER BY name`)
	120
208e2cbc AC	121	fun nextSeq (db, seq) =
208e2cbc AC	122	case C.oneRow db ($`SELECT nextval('^(seq)')`) of
ee587f7f	123	[id] => C.intFromSql id
208e2cbc AC	124	\| _ => raise Fail "Bad next sequence val"
208e2cbc AC	125
aaa50197	126	fun addUser (name, rname, bal, app, shares) =
208e2cbc AC	127	let
	128	val db = getDb ()
	129	val id = nextSeq (db, "WebUserSeq")
	130	in
2076f2da	131	C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined, app, shares, paypal, checkout)
aaa50197	132	VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal),
2076f2da	133	CURRENT_TIMESTAMP, ^(C.intToSql app), ^(C.intToSql shares),
7be17e39 AC	134	(SELECT paypal FROM MemberApp WHERE id = ^(C.intToSql app)),
7be17e39 AC	135	(SELECT checkout FROM MemberApp WHERE id = ^(C.intToSql app)))`);
ee587f7f	136	id
208e2cbc AC	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)),
aaa50197	145	bal = ^(C.intToSql (#bal user)), app = ^(C.intToSql (#app user)),
d5f8418b	146	shares = ^(C.intToSql (#shares user)),
9953bee7 AC	147	paypal = ^(nullableToSql (C.stringToSql o Util.normEmail) (#paypal user)),
9953bee7 AC	148	checkout = ^(nullableToSql (C.stringToSql o Util.normEmail) (#checkout user))
208e2cbc AC	149	WHERE id = ^(C.intToSql (#id user))`))
	150	end
	151
aaa50197	152	fun byPledge () =
d5f8418b	153	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
466c5944	154	FROM WebUserPaying
aaa50197	155	WHERE shares > 1
d90048bd	156	ORDER BY shares DESC, name`)
aaa50197	157
208e2cbc AC	158	fun deleteUser id =
	159	C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
	160
	161	fun validUsername name =
96bd398e	162	size name <= 12
03fc7566 AC	163	andalso size name > 0
	164	andalso Char.isLower (String.sub (name, 0))
	165	andalso CharVector.all Char.isAlphaNum name
208e2cbc AC	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
98a5f121 AC	172	fun dateString () =
	173	case C.oneRow (getDb ()) "SELECT CURRENT_DATE" of
	174	[d] => C.stringFromSql d
	175	\| r => rowError ("dateString", r)
	176
18eeb749 AC	177	type node = {id : int, name : string, descr : string, debian : string}
	178
	179	fun mkNodeRow [id, name, descr, debian] =
	180	{id = C.intFromSql id, name = C.stringFromSql name, descr = C.stringFromSql descr,
	181	debian = C.stringFromSql debian}
	182	\| mkNodeRow row = rowError ("node", row)
	183
	184	fun listNodes () =
	185	C.map (getDb ()) mkNodeRow ($`SELECT id, name, descr, debian
	186	FROM WebNode
ee252433	187	WHERE id IN (SELECT id FROM ActiveWebNode)
18eeb749 AC	188	ORDER BY name`)
	189
	190	fun nodeName id =
	191	case C.oneRow (getDb ()) ($`SELECT name
	192	FROM WebNode
	193	WHERE id = ^(C.intToSql id)`) of
	194	[name] => C.stringFromSql name
	195	\| row => rowError ("nodeName", row)
	196
	197	fun nodeDebian id =
	198	case C.oneRow (getDb ()) ($`SELECT debian
	199	FROM WebNode
	200	WHERE id = ^(C.intToSql id)`) of
	201	[debian] => C.stringFromSql debian
	202	\| row => rowError ("nodeDebian", row)
	203
30b8ceb4 AC	204	fun explain e =
	205	case e of
	206	OS.SysErr (name, sop) =>
	207	"System error: " ^ name ^
	208	(case sop of
	209	NONE => ""
	210	\| SOME syserr => ": " ^ OS.errorName syserr ^ ": " ^ OS.errorMsg syserr)
	211	\| _ => "Unknown"
	212
	213	fun tokens () =
	214	let
	215	val proc = Unix.execute ("/usr/bin/tokens", [])
	216	val inf = Unix.textInstreamOf proc
	217
	218	fun reader acc =
	219	case TextIO.inputLine inf of
	220	NONE => String.concat (rev acc)
	221	\| SOME s => reader (s :: acc)
	222	in
	223	reader []
	224	before (TextIO.closeIn inf;
	225	ignore (Unix.reap proc))
	226	end
	227
	228	fun tokensForked () =
	229	case Posix.Process.fork () of
	230	NONE => (OS.Process.system "/usr/bin/tokens >/tmp/tokens.child";
	231	OS.Process.exit OS.Process.success)
	232	\| _ => ignore (OS.Process.system "/usr/bin/tokens >/tmp/tokens.parent")
	233
59eb5381 AC	234	fun usersDiff (ls1, ls2) =
	235	{onlyInFirst = List.filter (fn x => not (Util.mem (x, ls2))) ls1,
	236	onlyInSecond = List.filter (fn x => not (Util.mem (x, ls1))) ls2}
	237
	238	fun listUsernames () = C.map (getDb ())
	239	(fn [name] => C.stringFromSql name
	240	\| row => rowError ("listUsernames", row))
	241	"SELECT name FROM WebUserActive ORDER BY name"
	242	fun usersInAfs () =
	243	let
	244	fun explore (dir, level, acc) =
	245	if level = 3 then
	246	dir :: acc
	247	else
	248	let
	249	val dr = Posix.FileSys.opendir dir
	250
	251	fun loop acc =
	252	case Posix.FileSys.readdir dr of
	253	NONE => acc
	254	\| SOME name =>
	255	let
	256	val dir' = OS.Path.joinDirFile {dir = dir,
	257	file = name}
	258
	259	val acc = explore (dir', level+1, acc)
	260	in
	261	loop acc
	262	end
	263	in
	264	loop acc
	265	before Posix.FileSys.closedir dr
	266	end
	267
	268	val acc = explore ("/afs/hcoop.net/user", 0, [])
	269	in
	270	List.map OS.Path.file acc
	271	end
	272
d5f8418b AC	273	fun searchPaypal paypal =
	274	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
	275	FROM WebUser
9953bee7	276	WHERE paypal = ^(C.stringToSql (normEmail paypal))
d5f8418b AC	277	ORDER BY name`)
	278
	279	fun searchCheckout checkout =
	280	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
	281	FROM WebUser
9953bee7	282	WHERE checkout = ^(C.stringToSql (normEmail checkout))
d5f8418b AC	283	ORDER BY name`)
d5f8418b AC	284
b1bb018a CE	285	fun searchRealName realname =
	286	C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
	287	FROM WebUser
29cabb75	288	WHERE rname ILIKE (^(C.stringToSql "%") \|\| trim (both ^(C.stringToSql " ") from ^(C.stringToSql realname)) \|\| ^(C.stringToSql "%"))
b1bb018a CE	289	ORDER BY name`)
b1bb018a CE	290
93f77ca7	291	end