some cleanup
git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@4556 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Jürgen Doser
parent
8553dced2d
commit
9811dcc1f6
|
|
@ -89,6 +89,7 @@ use "xmi_idtable.sml"; (* auxiliary table to store and dereference xmi.id's *
|
|||
use "xmi2rep.sml"; (* conversion XMI to Rep *)
|
||||
|
||||
|
||||
use "listeq.sml";
|
||||
use "mds.sig";
|
||||
use "component_uml.sml";
|
||||
use "secure_uml.sml";
|
||||
|
|
|
|||
|
|
@ -52,6 +52,8 @@ val action_stereotypes = ["dialect.entityaction",
|
|||
"dialect.entitymethodaction",
|
||||
"dialect.entityattributeaction"]
|
||||
|
||||
val root_stereotypes = ["compuml.entity"]
|
||||
|
||||
(** The list of all attributes of an entity. *)
|
||||
fun entity_contained_attributes (Entity c) =
|
||||
map EntityAttribute (Rep.attributes_of c)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,28 @@
|
|||
(** auxiliary functions on lists of eqtypes.*)
|
||||
signature LISTEQ =
|
||||
sig
|
||||
(** checks whether the list xs includes the value x. *)
|
||||
val includes: ''a list -> ''a -> bool
|
||||
|
||||
(** checks whether the intersection of xs and ys is nonempty. *)
|
||||
val overlaps: ''a list -> ''a list -> bool
|
||||
|
||||
(** checks whether the lists are disjunct, i.e., do not overlap. *)
|
||||
val disjunct: ''a list -> ''a list -> bool
|
||||
end
|
||||
|
||||
|
||||
structure ListEq:LISTEQ =
|
||||
struct
|
||||
open List
|
||||
|
||||
(** checks whether the list xs includes the value x. *)
|
||||
fun includes xs x = exists (fn y => y=x) xs
|
||||
|
||||
(** checks whether the intersection of xs and ys is nonempty. *)
|
||||
fun overlaps xs ys = includes (map (includes xs) ys) true
|
||||
|
||||
(** checks whether the lists are disjunct, i.e., do not overlap. *)
|
||||
fun disjunct xs ys = not (overlaps xs ys)
|
||||
|
||||
end
|
||||
|
|
@ -41,7 +41,12 @@ sig
|
|||
datatype Action = SimpleAction of string * Resource
|
||||
| CompositeAction of string * Resource
|
||||
|
||||
(** list of allowed stereotype names on attributes in permission classes. *)
|
||||
val action_stereotypes : string list
|
||||
|
||||
(** list of allowed stereotype names on classifiers to denote root resources. *)
|
||||
val root_stereotypes: string list
|
||||
|
||||
(* val action_names: string list *)
|
||||
|
||||
val subordinated_actions: Action -> Action list
|
||||
|
|
|
|||
|
|
@ -70,12 +70,10 @@ structure Design : DESIGN_LANGUAGE = Design
|
|||
|
||||
type User = string
|
||||
fun name_of (u:User) = u
|
||||
|
||||
|
||||
datatype Subject = Group of string * (string list)
|
||||
| User of User
|
||||
|
||||
|
||||
type Role = string
|
||||
type SubjectAssignment = (Subject * (Role list)) list
|
||||
|
||||
|
|
@ -125,24 +123,19 @@ fun check_permission (u,p) = false
|
|||
fun permissions_of u = nil
|
||||
|
||||
|
||||
fun stereotypes_of (Rep.Class {stereotypes,...}) = stereotypes
|
||||
| stereotypes_of (Rep.Enumeration {stereotypes,...}) = stereotypes
|
||||
| stereotypes_of (Rep.Primitive {stereotypes,...}) = stereotypes
|
||||
| stereotypes_of (Rep.Interface {stereotypes,...}) = stereotypes
|
||||
(** checks whether the classifier c has the stereotype s.
|
||||
* (could be moved to rep_core?)
|
||||
*)
|
||||
fun classifier_has_stereotype s c = ListEq.includes (Rep.stereotypes_of c) s
|
||||
|
||||
|
||||
fun has_no_stereotype strings c =
|
||||
not (List.exists (fn stereotype => List.exists (fn x => x = stereotype)
|
||||
strings) (stereotypes_of c))
|
||||
|
||||
fun has_stereotype string c =
|
||||
List.exists (fn x => x=string) (stereotypes_of c)
|
||||
|
||||
|
||||
fun filter_permission cs = List.filter (has_stereotype "secuml.permission") cs
|
||||
(** checks whether the classifier c has none of the given stereotypes *)
|
||||
fun classifier_has_no_stereotype strings c =
|
||||
ListEq.disjunct strings (Rep.stereotypes_of c)
|
||||
|
||||
fun filter_permission cs = List.filter (classifier_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_subject cs = List.filter (classifier_has_stereotype "secuml.user") cs
|
||||
fun filter_role cs = List.filter (classifier_has_stereotype "secuml.role") cs
|
||||
|
||||
|
||||
fun mkRole (Rep.Class c) = Rep.string_of_path (#name c)
|
||||
|
|
@ -152,50 +145,48 @@ fun mkRole (Rep.Class c) = Rep.string_of_path (#name c)
|
|||
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) = (
|
||||
{ name = (Rep.string_of_path (#name c)),
|
||||
roles = (map (Rep.string_of_path o Rep.name_of)
|
||||
(List.filter (classifier_has_stereotype "secuml.role")
|
||||
(map (fn (Rep_OclType.Classifier p) => Rep.class_of p cs)
|
||||
(List.filter Rep_OclType.is_Classifier
|
||||
(map #attr_type
|
||||
(Rep.attributes_of (Rep.Class c))))))),
|
||||
(* FIXME: find attached constraints *)
|
||||
constraints = nil,
|
||||
actions = let
|
||||
val atts = Rep.attributes_of (Rep.Class c)
|
||||
val root_resource =
|
||||
hd (List.filter (classifier_has_stereotype "compuml.entity")
|
||||
(map (fn (Rep_OclType.Classifier p) =>
|
||||
Rep.class_of p cs)
|
||||
(List.filter Rep_OclType.is_Classifier
|
||||
(map #attr_type
|
||||
atts))))
|
||||
handle _ => library.error ("could not find root resource "^
|
||||
"for class "^(Rep.string_of_path (#name c)))
|
||||
val action_attributes =
|
||||
List.filter (fn x => List.exists
|
||||
(fn y => List.exists
|
||||
(fn z => y= z)
|
||||
(#stereotypes x))
|
||||
Design.action_stereotypes) atts
|
||||
handle _ => library.error "could not parse permission attributes"
|
||||
in
|
||||
if action_attributes = []
|
||||
then library.error ("no action attributes found in permission "^
|
||||
(Rep.string_of_path (#name c)))
|
||||
else map (Design.parse_action root_resource) action_attributes
|
||||
end }
|
||||
handle _ => library.error "error in mkPermission" )
|
||||
| mkPermission _ _ = library.error "mkPermission called on something that is not a class"
|
||||
|
||||
|
||||
fun mkPermission cs (Rep.Class c) =
|
||||
let val atts = Rep.attributes_of (Rep.Class c)
|
||||
val classifiers = List.mapPartial (fn (Rep_OclType.Classifier p)
|
||||
=> SOME (Rep.class_of p cs)
|
||||
| _ => NONE)
|
||||
(map #attr_type atts)
|
||||
val role_classes = List.filter (classifier_has_stereotype "secuml.role")
|
||||
classifiers
|
||||
val root_classes = List.filter (fn x => ListEq.overlaps (Rep.stereotypes_of x)
|
||||
Design.root_stereotypes)
|
||||
classifiers
|
||||
val root_resource = hd root_classes
|
||||
handle Empty => library.error ("no root resource found for permission "^
|
||||
Rep.string_of_path (#name c))
|
||||
val action_attributes =
|
||||
List.filter (fn x => List.exists
|
||||
(fn y => List.exists
|
||||
(fn z => y= z)
|
||||
(#stereotypes x))
|
||||
Design.action_stereotypes) atts
|
||||
handle _ => library.error "could not parse permission attributes"
|
||||
in
|
||||
{ name = (Rep.string_of_path (#name c)),
|
||||
roles = (map (Rep.string_of_path o Rep.name_of) role_classes),
|
||||
(* FIXME: find attached constraints *)
|
||||
constraints = nil,
|
||||
actions = if action_attributes = []
|
||||
then library.error ("no action attributes found in permission "^
|
||||
(Rep.string_of_path (#name c)))
|
||||
else map (Design.parse_action root_resource) action_attributes }
|
||||
end
|
||||
| mkPermission _ _ = library.error ("mkPermission called on something "^
|
||||
"that is not a class")
|
||||
|
||||
|
||||
(* FIXME *)
|
||||
fun mkPartialOrder xs = ListPair.zip (xs,xs)
|
||||
|
||||
fun parse (cs:Rep_Core.Classifier list) =
|
||||
(List.filter (has_no_stereotype ["secuml.permission","secuml.role","secuml.subject"]) cs,
|
||||
(List.filter (classifier_has_no_stereotype ["secuml.permission","secuml.role","secuml.subject"]) cs,
|
||||
{ config_type = "SecureUML",
|
||||
permissions = map (mkPermission cs) (filter_permission cs),
|
||||
subjects = map mkSubject (filter_subject cs),
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ Group is
|
|||
#endif
|
||||
../lib/fxp/src/fxlib.cm
|
||||
library.sml
|
||||
listeq.sml
|
||||
rep_ocl.sml
|
||||
rep_state_machines.sml
|
||||
rep_activity_graphs.sml
|
||||
|
|
|
|||
Loading…
Reference in New Issue