fixed bug in handling composite actions

git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@4554 3260e6d1-4efc-4170-b0a7-36055960796d

src/codegen/componentuml_cartridge.sml

@@ -58,7 +58,7 @@ fun atomic_actions_from_context env =
 fun permissions_for_action env act = 
     List.filter (fn x => SuperCart.Security.permission_includes_action x act)
                 (SuperCart.PermissionSet (unpack env))
-    
+                
 (********** ADDING/MODIFYING VARIABLE SUBSTITUTIONS *****************************************)
 (*	lookup  environment -> string -> string			
  * might override some lookup entries of the base cartridge 

src/component_uml.sml

@@ -55,21 +55,21 @@ val action_stereotypes = ["dialect.entityaction",
 (** The list of all attributes of an entity. *)
 fun entity_contained_attributes (Entity c) =
     map EntityAttribute (Rep.attributes_of c)
-  | entity_contained_attributes _ = nil
+  | entity_contained_attributes _ = library.error "entity_contained_attributes called on something that is not an entity"
 
 (** the list of all methods of an entity *)
 fun entity_contained_methods (Entity c) = map EntityMethod (Rep.operations_of c)
-  | entity_contained_methods _ = nil
+  | entity_contained_methods _ = library.error "entity_contained_methods called on something that is not an entity"
 
 (** The list of all side-effect free methods of an entity. *)
 fun entity_contained_read_methods (Entity c) =
     map EntityMethod (List.filter #isQuery (Rep.operations_of c))
-  | entity_contained_read_methods _ = nil
+  | entity_contained_read_methods _ = library.error "entity_contained_read_methods called on something that is not an entity"
 		
 (** The list of all methods with side-effects of an entity *)
 fun entity_contained_update_methods (Entity c) =
     map EntityMethod (List.filter (not o #isQuery) (Rep.operations_of c))
-  | entity_contained_update_methods _ = nil
+  | entity_contained_update_methods _ = library.error "entity_contained_update_methods called on something that is not an entity"
 
 (** The resources that are contained in the given resource. *)
 fun contained_resources x = 
@@ -91,6 +91,8 @@ fun parse_entity_action root att_name "create"     =
 	SimpleAction ("delete", (Entity root)) 
   | parse_entity_action root att_name "fullaccess" =
 	CompositeAction ("fullaccess", (Entity root)) 	
+  | parse_entity_action root att_name s = library.error ("unknown action type "^s^
+                                                         " for entity action")
 	
 (** parses an entity attribute action permission attribute. *)
 fun parse_attribute_action root name "read"       =
@@ -108,13 +110,17 @@ fun parse_attribute_action root name "read"       =
                        (EntityAttribute ((hd o List.filter (fn x => #name x = name)) 
                                              (Rep.attributes_of root))))
       handle Empty => library.error "did not find attribute")
+  | parse_attribute_action root name s = library.error ("unknown action type "^s^
+                                                        "for attribute action")
 
 (** parses an entity method action permission attribute. *)
 fun parse_method_action root name "execute" 
-  = SimpleAction ("execute", 
-				  (EntityMethod ((hd o List.filter (fn x => #name x = name)) 
-									 (Rep.operations_of root))))
-	handle Empty => library.error "did not find method"
+  = (SimpleAction ("execute", 
+                   (EntityMethod ((hd o List.filter (fn x => #name x = name)) 
+                                      (Rep.operations_of root))))
+     handle Empty => library.error "did not find method")
+  | parse_method_action roor name s = library.error ("unknown action type "^s^
+                                                     "for method action")
 
 (**
  * parses a permission attribute according to the ComponentUML 
@@ -123,7 +129,9 @@ fun parse_method_action root name "execute"
 fun parse_action root (att:Rep.attribute) =
 	let val att_name = #name att
 		val att_type = #attr_type att
-		val action_name = (hd o rev o (fn Rep_OclType.Classifier x => x)) att_type 
+        val cls_path = case att_type of Rep_OclType.Classifier x => x
+                                      | _ => library.error "permission attribute type is not a classifier"
+		val action_name = hd (rev cls_path) 
         fun resource_path name = (hd o List.tl) (String.tokens (fn x => x= #".") name)
 	in case hd (#stereotypes att) 
 		of "dialect.entityaction" => 
@@ -184,4 +192,5 @@ fun subordinated_actions (SimpleAction _) = nil
   | subordinated_actions (CompositeAction ("full_access", a as (EntityAttribute ae)))
     = [SimpleAction ("read", a),
        SimpleAction ("update", a)]
+  | subordinated_actions (CompositeAction _) = library.error "encountered unknown composite action type in subordinated_actions"
 end

src/secure_uml.sml

@@ -87,17 +87,13 @@ type Permission = {name: string,
 
 fun actions_of (p:Permission) = #actions p
 
-fun permission_includes_action (p:Permission) (a:Design.Action) =
-    (List.exists (fn x =>  x=a ) (actions_of p))
-    orelse (List.exists (fn x => x) (map (permission_includes_action p)
-                                         (Design.subordinated_actions a)))
-    
+(** test whether a1 is (transitively) a subordinated_action of a2 *)
 fun is_contained_in a1 a2 = (a1 = a2) orelse 
-							List.exists (fn x=> x=true) 
-                                        ((List.map (is_contained_in a1) 
+							List.exists (is_contained_in a1) 
                                                    (Design.subordinated_actions a2))) 
 
-fun isInPermission a (p:Permission) = 
+(** test whether the permission p covers the action a. *)
+fun permission_includes_action (p:Permission) (a:Design.Action) = 
     List.exists (is_contained_in a) (#actions p)
 
 type Config_Type = string
@@ -146,17 +142,19 @@ fun has_stereotype string c =
 fun filter_permission cs = List.filter (has_stereotype "secuml.permission") cs
 (* FIXME: handle groups also *)
 fun filter_subject cs = List.filter (has_stereotype "secuml.user") cs
-fun filter_role cs = List.filter (has_stereotype "secuml.role") cs
-
+fun filter_role cs = List.filter (has_stereotype "secuml.role") cs 
 
+ 
 fun mkRole (Rep.Class c)  = Rep.string_of_path (#name c)
+  | mkRole _ = library.error "mkRole called on something that is not a class"
 
 (* FIXME: handle groups also *)
 fun mkSubject (Rep.Class c) = User (Rep.string_of_path (#name c))
+  | mkSubject _ = library.error "mkSubject called on something that is not a class"
 
 fun classifier_has_stereotype s c = List.exists (fn x => x = s) 
 												(Rep.stereotypes_of c)
-fun mkPermission cs (Rep.Class c) =  
+fun mkPermission cs (Rep.Class c) =  (
 	{ name  = (Rep.string_of_path (#name c)),
 	  roles = (map (Rep.string_of_path o Rep.name_of)
 				   (List.filter (classifier_has_stereotype "secuml.role") 
@@ -190,7 +188,8 @@ fun mkPermission cs (Rep.Class c) =
                               (Rep.string_of_path (#name c)))
           else map (Design.parse_action root_resource) action_attributes
 	  end }
-	handle _ => library.error "error in mkPermission" 
+	handle _ => library.error "error in mkPermission" )
+  | mkPermission _ _ = library.error "mkPermission called on something that is not a class"
 
 (* FIXME *) 
 fun mkPartialOrder xs = ListPair.zip (xs,xs)