init.sml

   1 structure Init :> INIT =
   2 struct
   3
   4 open Util Sql
   5 structure C = PgClient
   6
   7 exception Access of string
   8
   9 fun conn () = C.conn "dbname='hcoop'"
  10 val close = C.close
  11
  12 type user = {id : int, name : string, rname : string, bal : int, joined : C.timestamp}
  13
  14 val db = ref (NONE : C.conn option)
  15 val user = ref (NONE : user option)
  16
  17 fun fromSql v =
  18     if C.isNull v then
  19         "NULL"
  20     else
  21         C.stringFromSql v
  22
  23 fun rowError (tab, vs) = raise Fail ("Bad " ^ tab ^ "row: " ^ makeSet fromSql vs)
  24
  25 fun getDb () = valOf (!db)
  26
  27 fun mkUserRow [id, name, rname, bal, joined] =
  28     {id = C.intFromSql id, name = C.stringFromSql name, rname = C.stringFromSql rname,
  29      bal = C.intFromSql bal, joined = C.timestampFromSql joined}
  30   | mkUserRow row = rowError ("user", row)
  31
  32 fun init () =
  33     let
  34         val c = conn ()
  35     in
  36         C.dml c "BEGIN";
  37         case Web.getCgi "REMOTE_USER" of
  38             NONE => raise Fail "Not logged in"
  39           | SOME name =>
  40             (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined
  41                                      FROM WebUser
  42                                      WHERE name=^(C.stringToSql name)`) of
  43                  NONE => raise Fail "User not found"
  44                | SOME r => user := SOME (mkUserRow r));
  45             db := SOME c
  46     end
  47
  48 fun done () =
  49     let
  50         val db = getDb ()
  51     in
  52         C.dml db "COMMIT";
  53         close db
  54     end
  55
  56 fun getUser () = valOf (!user)
  57 fun getUserId () = #id (getUser ())
  58 fun getUserName () = #name (getUser ())
  59
  60 fun lookupUser id =
  61     mkUserRow (C.oneRow (getDb ()) ($`SELECT id, name, rname, bal, joined
  62                                       FROM WebUser
  63                                       WHERE id = ^(C.intToSql id)`))
  64
  65 fun listUsers () =
  66     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined
  67                                   FROM WebUser
  68                                   ORDER BY name`)
  69
  70 fun nextSeq (db, seq) =
  71     case C.oneRow db ($`SELECT nextval('^(seq)')`) of
  72         [id] => C.intFromSql id
  73       | _ => raise Fail "Bad next sequence val"
  74
  75 fun addUser (name, rname, bal) =
  76     let
  77         val db = getDb ()
  78         val id = nextSeq (db, "WebUserSeq")
  79     in
  80         C.dml db ($`INSERT INTO WebUser (id, name, rname, bal, joined)
  81                     VALUES (^(C.intToSql id), ^(C.stringToSql name), ^(C.stringToSql rname), ^(C.intToSql bal), CURRENT_TIMESTAMP)`);
  82         id
  83     end
  84
  85 fun modUser (user : user) =
  86     let
  87         val db = getDb ()
  88     in
  89         ignore (C.dml db ($`UPDATE WebUser SET
  90                             name = ^(C.stringToSql (#name user)), rname = ^(C.stringToSql (#rname user)),
  91                                bal = ^(C.intToSql (#bal user))
  92                             WHERE id = ^(C.intToSql (#id user))`))
  93     end
  94
  95 fun deleteUser id =
  96     C.dml (getDb ()) ($`DELETE FROM WebUser WHERE id = ^(C.intToSql id)`)
  97
  98 fun validUsername name =
  99     size name <= 10
 100     andalso CharVector.all Char.isAlpha name
 101
 102 fun userNameToId name =
 103     case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebUser WHERE name = ^(C.stringToSql name)`) of
 104         SOME [id] => SOME (C.intFromSql id)
 105       | _ => NONE
 106
 107 end