Changed to use new smlsql interface

[bpt/portal.git] / init.sml

structure Init :> INIT =
struct

open Util Sql
structure C = PgClient

exception Access of string

fun conn () = C.conn "dbname='hcoop'"
val close = C.close

type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp}

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] =
    {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
     bal = C.intFromSql bal, joined = C.timestampFromSql joined}
  | mkUserRow row = rowError ("user", row)

fun init () =
    let
	val c = conn ()
    in
	C.dml c "BEGIN";
	case Web.getCgi "REMOTE_USER" of
	    NONE => raise Fail "Not logged in"
	  | SOME name =>
	    (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined
  				     FROM WebUser
				     WHERE name=^(C.stringToSql name)`) of
		 NONE => raise Fail "User not found"
	       | SOME r => user := SOME (mkUserRow r));
	    db := SOME c
    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
				      FROM WebUser
			     	      WHERE id = ^(C.intToSql id)`))

fun listUsers () =
    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined
			          FROM WebUser
			          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) =
    let
	val db = getDb ()
	val id = nextSeq (db, "WebUserSeq")
    in
	C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined)
		    VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP)`);
	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))
			    WHERE id = ^(C.intToSql (#id user))`))
    end

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

fun userNameToId name =
    case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
	SOME [id] => SOME (C.intFromSql id)
      | _ => NONE

end