group.sml

   1 structure Group :> GROUP =
   2 struct
   3
   4 open Util Sql Init
   5
   6
   7 (* Managing groups *)
   8
   9 type group = {id :int, name : string}
  10
  11 fun mkGroupRow [id, name] =
  12     {id = C.intFromSql id, name = C.stringFromSql name}
  13   | mkGroupRow row = Init.rowError ("group", row)
  14
  15 fun addGroup name =
  16     let
  17         val db = getDb ()
  18         val id = nextSeq (db, "WebGroupSeq")
  19     in
  20         C.dml db ($`INSERT INTO WebGroup (id, name)
  21                     VALUES (^(C.intToSql id), ^(C.stringToSql name))`);
  22         id
  23     end
  24
  25 fun lookupGroup id =
  26     let
  27         val c = getDb ()
  28     in
  29         (case C.oneOrNoRows c ($`SELECT id, name FROM WebGroup WHERE id = ^(C.intToSql id)`) of
  30              NONE => raise Fail "Group not found"
  31            | SOME r => mkGroupRow r)
  32     end
  33
  34 fun modGroup (group : group) =
  35     let
  36         val db = getDb ()
  37     in
  38         ignore (C.dml db ($`UPDATE WebGroup
  39                             SET name = ^(C.stringToSql (#name group))
  40                             WHERE id = ^(C.intToSql (#id group))`))
  41     end
  42
  43 fun deleteGroup id =
  44     ignore (C.dml (getDb ()) ($`DELETE FROM WebGroup WHERE id = ^(C.intToSql id)`))
  45
  46 fun listGroups () =
  47     C.map (getDb ()) mkGroupRow ($`SELECT id, name FROM WebGroup
  48                                    ORDER BY name`)
  49
  50 (* Checking group membership *)
  51
  52 fun userInGroupNum (usr, grp) =
  53     let
  54         val c = getDb ()
  55     in
  56         (case C.oneOrNoRows c ($`SELECT COUNT( * )
  57                                     FROM Membership
  58                                     WHERE (grp IN (0, ^(C.intToSql grp)))
  59                                        AND usr = ^(C.intToSql usr)`) of
  60              SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0
  61            | _ => false)
  62     end
  63
  64 fun userInGroupName (usr, grp) =
  65     let
  66         val c = getDb ()
  67     in
  68         (case C.oneOrNoRows c ($`SELECT COUNT( * )
  69                                     FROM Membership, WebGroup
  70                                     WHERE (grp = 0 OR (name = ^(C.stringToSql grp) AND grp = id))
  71                                        AND usr = ^(C.intToSql usr)`) of
  72              SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0
  73            | _ => false)
  74     end
  75
  76
  77 (* Managing group memberships *)
  78
  79 type membership = {usr : int, grp : int}
  80
  81 fun addToGroup (mem : membership) =
  82     let
  83         val usr = #usr mem
  84         val grp = #grp mem
  85     in
  86         case C.oneOrNoRows (getDb ()) ($`SELECT * FROM Membership WHERE grp = ^(C.intToSql grp) AND usr = ^(C.intToSql usr)`) of
  87             NONE => ignore (C.dml (getDb ()) ($`INSERT INTO Membership (grp, usr)
  88                                                 VALUES (^(C.intToSql grp), ^(C.intToSql usr))`))
  89           | SOME _ => ()
  90     end
  91
  92 fun addToGroups (usr, grps) =
  93     List.app (fn grp => addToGroup {usr = usr, grp = grp}) grps
  94
  95 fun removeFromGroup (mem : membership) =
  96     let
  97         val usr = #usr mem
  98         val grp = #grp mem
  99     in
 100         ignore (C.dml (getDb ()) ($`DELETE FROM Membership
 101                                     WHERE grp = ^(C.intToSql grp)
 102                                        AND usr = ^(C.intToSql usr)`))
 103     end
 104
 105 fun mkMembershipRow [grp, usr] =
 106     {grp = C.intFromSql grp, usr = C.intFromSql usr}
 107   | mkMembershipRow row = Init.rowError ("membership", row)
 108
 109 fun groupMembers grp =
 110     C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
 111                                   FROM Membership, WebUser
 112                                   WHERE grp = ^(C.intToSql grp)
 113                                     AND usr = id
 114                                   ORDER BY name`)
 115
 116
 117 (* Checking memberships of the current user *)
 118
 119 fun inGroupNum grp = userInGroupNum (getUserId(), grp)
 120 fun inGroupName grp = userInGroupName (getUserId(), grp)
 121
 122 fun requireGroupNum grp =
 123     if inGroupNum grp then
 124         ()
 125     else
 126         raise Access ("You aren't a member of group #" ^ Int.toString grp)
 127
 128 fun requireGroupName grp =
 129     if inGroupName grp then
 130         ()
 131     else
 132         raise Access ("You aren't a member of group \"" ^ grp ^ "\"")
 133
 134 fun validGroupName name =
 135     size name <= 10
 136     andalso CharVector.all Char.isAlphaNum name
 137
 138 fun groupNameToId name =
 139     case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebGroup WHERE name = ^(C.stringToSql name)`) of
 140         SOME [id] => SOME (C.intFromSql id)
 141       | _ => NONE
 142
 143 end