Fix file paths for recursive rmdom

[hcoop/domtool2.git] / src / acl.sml

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006, Adam Chlipala
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 *)

(* Per-user access control lists for resources various *)

structure Acl :> ACL = struct

type acl = {user : string,
	    class : string,
	    value : string}

structure SM = DataStructures.StringMap
structure SS = DataStructures.StringSet

val acl : SS.set SM.map SM.map ref = ref SM.empty

fun query {user, class, value} =
    case SM.find (!acl, user) of
	NONE => false
      | SOME classes =>
	case SM.find (classes, class) of
	    NONE => false
	  | SOME values => SS.member (values, value)

fun queryAll user =
    case SM.find (!acl, user) of
	NONE => []
      | SOME classes => SM.foldri (fn (class, values, out) =>
				      (class, SS.foldr (op::) [] values) :: out)
				  [] classes

fun users () = SM.foldri (fn (user, _, ls) => user :: ls) [] (!acl)

fun whoHas {class, value} =
    SM.foldri (fn (user, classes, users) =>
		  case SM.find (classes, class) of
		      NONE => users
		    | SOME values =>
		      if SS.member (values, value) then
			  user :: users
		      else
			  users) [] (!acl)

fun class {user, class} =
    case SM.find (!acl, user) of
	NONE => SS.empty
      | SOME classes =>
	case SM.find (classes, class) of
	    NONE => SS.empty
	  | SOME values => values

fun grant {user, class, value} =
    let
	val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
	val values = Option.getOpt (SM.find (classes, class), SS.empty)
    in
	acl := SM.insert (!acl, user,
			  SM.insert (classes, class,
				     SS.add (values, value)))
    end

fun revoke {user, class, value} =
    let
	val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
	val values = Option.getOpt (SM.find (classes, class), SS.empty)

	val values = if SS.member (values, value) then
			 SS.delete (values, value)
		     else
			 values
    in
	acl := SM.insert (!acl, user,
			  SM.insert (classes, class,
				     values))
    end

fun read fname =
    let
	val inf = TextIO.openIn fname

	fun users usrs =
	    case TextIO.inputLine inf of
		NONE => usrs
	      | SOME line =>
		case String.tokens Char.isSpace line of
		    [user] =>
		    let
			fun classes clss =
			    case TextIO.inputLine inf of
				NONE => clss
			      | SOME line =>
				case String.tokens Char.isSpace line of
				    [] => clss
				  | class :: values =>
				    classes (SM.insert (clss, class,
							foldl SS.add' SS.empty values))
		    in
			users (SM.insert (usrs, user, classes SM.empty))
		    end
		  | _ => raise Fail "Unexpected ACL file format"
    in
	acl := users SM.empty
	before TextIO.closeIn inf
    end

fun write fname =
    let
	val outf = TextIO.openOut fname

	val writeValues = SS.app (fn value =>
				     (TextIO.output (outf, " ");
				      TextIO.output (outf, value)))

	val writeClasses = SM.appi (fn (class, values) =>
				       if SS.isEmpty values then
					   ()
				       else
					   (TextIO.output (outf, class);
					    writeValues values;
					    TextIO.output (outf, "\n")))

	val writeUsers = SM.appi (fn (user, classes) =>
				     if SM.numItems classes = 0 then
					 ()
				     else
					 (TextIO.output (outf, user);
					  TextIO.output (outf, "\n");
					  writeClasses classes;
					  TextIO.output (outf, "\n")))
    in
	writeUsers (!acl);
	TextIO.closeOut outf
    end

end