X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/1824f573f7f8720514af1dc94d7cfb1de5b15fef..51cc45f7d84d0d92700b461a1296b9aa748dd88e:/src/acl.sml?ds=inline

diff --git a/src/acl.sml b/src/acl.sml
index be30fdf..85287d9 100644
--- a/src/acl.sml
+++ b/src/acl.sml
@@ -64,6 +64,10 @@ fun class {user, class} =
 	    NONE => SS.empty
 	  | SOME values => values
 
+fun rmuser user =
+    (acl := #1 (SM.remove (!acl, user)))
+    handle NotFound => ()
+
 fun grant {user, class, value} =
     let
 	val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
@@ -83,12 +87,28 @@ fun revoke {user, class, value} =
 			 SS.delete (values, value)
 		     else
 			 values
+
+	val classes = if SS.isEmpty values then
+			  (#1 (SM.remove (classes, class)))
+			  handle NotFound => classes
+		      else
+			  SM.insert (classes, class, values)
     in
-	acl := SM.insert (!acl, user,
-			  SM.insert (classes, class,
-				     values))
+	if SM.numItems classes = 0 then
+	    (acl := #1 (SM.remove (!acl, user)))
+	    handle NotFound => ()
+	else
+	    acl := SM.insert (!acl, user, classes)
     end
 
+fun revokeFromAll {class, value} =
+    acl := SM.map (fn classes =>
+		      case SM.find (classes, class) of
+			  NONE => classes
+			| SOME values =>
+			  ((SM.insert (classes, class, SS.delete (values, value)))
+			   handle NotFound => classes)) (!acl)
+
 fun read fname =
     let
 	val inf = TextIO.openIn fname
@@ -147,4 +167,16 @@ fun write fname =
 	TextIO.closeOut outf
     end
 
+fun queryDomain {user, domain} =
+    let
+	fun trySuffix parts =
+	    case parts of
+		[] => false
+	      | first :: rest =>
+		query {user = user, class = "domain", value = String.concatWith "." parts}
+		orelse trySuffix rest
+    in
+	trySuffix (String.fields (fn ch => ch = #".") domain)
+    end
+
 end