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