src/acl.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, Adam Chlipala
   3  *
   4  * This program is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU General Public License
   6  * as published by the Free Software Foundation; either version 2
   7  * of the License, or (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  17  *)
  18
  19 (* Per-user access control lists for resources various *)
  20
  21 structure Acl :> ACL = struct
  22
  23 type acl = {user : string,
  24             class : string,
  25             value : string}
  26
  27 structure SM = DataStructures.StringMap
  28 structure SS = DataStructures.StringSet
  29
  30 val acl : SS.set SM.map SM.map ref = ref SM.empty
  31
  32 fun query {user, class, value} =
  33     case SM.find (!acl, user) of
  34         NONE => false
  35       | SOME classes =>
  36         case SM.find (classes, class) of
  37             NONE => false
  38           | SOME values => SS.member (values, value)
  39
  40 fun queryAll user =
  41     case SM.find (!acl, user) of
  42         NONE => []
  43       | SOME classes => SM.foldri (fn (class, values, out) =>
  44                                       (class, SS.foldr (op::) [] values) :: out)
  45                                   [] classes
  46
  47 fun users () = SM.foldri (fn (user, _, ls) => user :: ls) [] (!acl)
  48
  49 fun whoHas {class, value} =
  50     SM.foldri (fn (user, classes, users) =>
  51                   case SM.find (classes, class) of
  52                       NONE => users
  53                     | SOME values =>
  54                       if SS.member (values, value) then
  55                           user :: users
  56                       else
  57                           users) [] (!acl)
  58
  59 fun class {user, class} =
  60     case SM.find (!acl, user) of
  61         NONE => SS.empty
  62       | SOME classes =>
  63         case SM.find (classes, class) of
  64             NONE => SS.empty
  65           | SOME values => values
  66
  67 fun rmuser user =
  68     (acl := #1 (SM.remove (!acl, user)))
  69     handle NotFound => ()
  70
  71 fun grant {user, class, value} =
  72     let
  73         val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
  74         val values = Option.getOpt (SM.find (classes, class), SS.empty)
  75     in
  76         acl := SM.insert (!acl, user,
  77                           SM.insert (classes, class,
  78                                      SS.add (values, value)))
  79     end
  80
  81 fun revoke {user, class, value} =
  82     let
  83         val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
  84         val values = Option.getOpt (SM.find (classes, class), SS.empty)
  85
  86         val values = if SS.member (values, value) then
  87                          SS.delete (values, value)
  88                      else
  89                          values
  90
  91         val classes = if SS.isEmpty values then
  92                           (#1 (SM.remove (classes, class)))
  93                           handle NotFound => classes
  94                       else
  95                           SM.insert (classes, class, values)
  96     in
  97         if SM.numItems classes = 0 then
  98             (acl := #1 (SM.remove (!acl, user)))
  99             handle NotFound => ()
 100         else
 101             acl := SM.insert (!acl, user, classes)
 102     end
 103
 104 fun revokeFromAll {class, value} =
 105     acl := SM.map (fn classes =>
 106                       case SM.find (classes, class) of
 107                           NONE => classes
 108                         | SOME values =>
 109                           ((SM.insert (classes, class, SS.delete (values, value)))
 110                            handle NotFound => classes)) (!acl)
 111
 112 fun read fname =
 113     let
 114         val inf = TextIO.openIn fname
 115
 116         fun users usrs =
 117             case TextIO.inputLine inf of
 118                 NONE => usrs
 119               | SOME line =>
 120                 case String.tokens Char.isSpace line of
 121                     [user] =>
 122                     let
 123                         fun classes clss =
 124                             case TextIO.inputLine inf of
 125                                 NONE => clss
 126                               | SOME line =>
 127                                 case String.tokens Char.isSpace line of
 128                                     [] => clss
 129                                   | class :: values =>
 130                                     classes (SM.insert (clss, class,
 131                                                         foldl SS.add' SS.empty values))
 132                     in
 133                         users (SM.insert (usrs, user, classes SM.empty))
 134                     end
 135                   | _ => raise Fail "Unexpected ACL file format"
 136     in
 137         acl := users SM.empty
 138         before TextIO.closeIn inf
 139     end
 140
 141 fun write fname =
 142     let
 143         val outf = TextIO.openOut fname
 144
 145         val writeValues = SS.app (fn value =>
 146                                      (TextIO.output (outf, " ");
 147                                       TextIO.output (outf, value)))
 148
 149         val writeClasses = SM.appi (fn (class, values) =>
 150                                        if SS.isEmpty values then
 151                                            ()
 152                                        else
 153                                            (TextIO.output (outf, class);
 154                                             writeValues values;
 155                                             TextIO.output (outf, "\n")))
 156
 157         val writeUsers = SM.appi (fn (user, classes) =>
 158                                      if SM.numItems classes = 0 then
 159                                          ()
 160                                      else
 161                                          (TextIO.output (outf, user);
 162                                           TextIO.output (outf, "\n");
 163                                           writeClasses classes;
 164                                           TextIO.output (outf, "\n")))
 165     in
 166         writeUsers (!acl);
 167         TextIO.closeOut outf
 168     end
 169
 170 end