support for superroles on secureuml cartridge
git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@6047 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Jürgen Doser
parent
a2fe623aea
commit
dcc7a40daa
|
|
@ -80,8 +80,8 @@ fun substituteVars e s =
|
|||
let val tkl = Gcg_Helper.joinEscapeSplitted "$" (Gcg_Helper.fieldSplit s #"$")
|
||||
in
|
||||
String.concat (map2EveryOther (C.lookup e) tkl)
|
||||
handle ex => error ("in GCG_Core.substituteVars: lookup failure for variable "^(String.concat tkl))
|
||||
end
|
||||
|
||||
|
||||
(** traverses a templateParseTree and executes the given instructions *)
|
||||
fun write env (Tpl_Parser.RootNode(l)) = List.app (write env) l
|
||||
|
|
|
|||
|
|
@ -36,9 +36,11 @@ structure Security:SECUREUML
|
|||
include BASE_CARTRIDGE where
|
||||
type Model = Rep.Classifier list * Security.Configuration
|
||||
|
||||
val PermissionSet: environment -> Security.Permission list
|
||||
val curPermission : environment -> Security.Permission option
|
||||
val curRole : environment -> string option
|
||||
val PermissionSet : environment -> Security.Permission list
|
||||
val curPermission : environment -> Security.Permission option
|
||||
val curRole : environment -> string option
|
||||
val curSubject : environment -> Security.Subject option
|
||||
val curSuperrole : environment -> string option
|
||||
val curConstraint : environment -> Rep_OclTerm.OclTerm option
|
||||
|
||||
|
||||
|
|
@ -53,6 +55,7 @@ functor SecureUML_Cartridge(structure SuperCart : BASE_CARTRIDGE;
|
|||
structure D: DESIGN_LANGUAGE) : SECUREUML_CARTRIDGE =
|
||||
struct
|
||||
|
||||
open library
|
||||
structure Security = SecureUML(structure Design = D)
|
||||
|
||||
type Model = Rep.Classifier list * Security.Configuration
|
||||
|
|
@ -62,19 +65,23 @@ type environment = { model : Model,
|
|||
curPermission : Security.Permission option,
|
||||
curSubject : Security.Subject option,
|
||||
curRole : string option,
|
||||
curSuperrole : string option,
|
||||
curConstraint : Rep_OclTerm.OclTerm option,
|
||||
extension : SuperCart.environment }
|
||||
|
||||
fun PermissionSet (env : environment) = (#PermissionSet env)
|
||||
fun curPermission (env : environment) = (#curPermission env)
|
||||
fun curRole (env : environment) = (#curRole env)
|
||||
fun curSuperrole (env : environment) = (#curSuperrole env)
|
||||
fun curConstraint (env : environment) = (#curConstraint env)
|
||||
fun curSubject (env : environment) = (#curSubject env)
|
||||
|
||||
fun curPermission' (env : environment) = Option.valOf (#curPermission env)
|
||||
fun curRole' (env : environment) = Option.valOf (#curRole env)
|
||||
fun curConstraint' (env : environment) = Option.valOf (#curConstraint env)
|
||||
|
||||
|
||||
fun security_conf (env: environment) = #2 (#model env)
|
||||
|
||||
fun initEnv model = let val m = Security.parse model
|
||||
in
|
||||
{ model = m,
|
||||
|
|
@ -82,6 +89,7 @@ fun initEnv model = let val m = Security.parse model
|
|||
curPermission = NONE,
|
||||
curSubject = NONE,
|
||||
curRole = NONE,
|
||||
curSuperrole = NONE,
|
||||
curConstraint = NONE,
|
||||
extension = SuperCart.initEnv (#1 m) } : environment
|
||||
end
|
||||
|
|
@ -96,6 +104,7 @@ fun pack (env: environment) (new_env : SuperCart.environment)
|
|||
curSubject = #curSubject env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = #curRole env,
|
||||
curSuperrole = #curSuperrole env,
|
||||
curConstraint = #curConstraint env,
|
||||
extension = new_env}
|
||||
|
||||
|
|
@ -122,8 +131,9 @@ fun lookup env "permission_name" = #name (curPermission' env)
|
|||
| lookup env "role_name" = name_of_role (curRole' env)
|
||||
| lookup env "constraint" = Ocl2String.ocl2string false (curConstraint' env)
|
||||
| lookup env "subject_name" = (Security.subject_name_of o valOf o curSubject) env
|
||||
| lookup env "superrole_name" = (name_of_role o valOf o curSuperrole) env
|
||||
| lookup env s = SuperCart.lookup (unpack env) s
|
||||
|
||||
handle Option => error "variable outside of context"
|
||||
(********** ADDING IF-CONDITION TYPE *****************************************)
|
||||
fun test env "first_permission" = (curPermission' env = hd (PermissionSet env))
|
||||
| test env "first_role" = (curRole' env = hd (#roles (curPermission' env)))
|
||||
|
|
@ -147,17 +157,37 @@ fun foreach_role (env:environment)
|
|||
| NONE => case #curSubject env
|
||||
of SOME s => (Security.subject_roles_of s o #2 o #model) env
|
||||
| NONE => (Security.all_roles o #2 o #model) env
|
||||
fun env_from_list_item r ={ model = #model env,
|
||||
fun env_from_list_item r ={ model = #model env,
|
||||
PermissionSet = #PermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curSubject = #curSubject env,
|
||||
curRole = SOME r ,
|
||||
curSuperrole = NONE,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env } : environment
|
||||
extension = #extension env } : environment
|
||||
in
|
||||
List.map env_from_list_item roles
|
||||
end
|
||||
|
||||
|
||||
(** iterate over all superroles in the context of a role *)
|
||||
fun foreach_superrole (env:environment) =
|
||||
let val cur = valOf (curRole env )
|
||||
handle Option => error ("no current role")
|
||||
val superroles = List.mapPartial (fn (r,s) => if r=cur then SOME s
|
||||
else NONE)
|
||||
(#rh (security_conf env))
|
||||
fun env_from_list_item s = { model = #model env,
|
||||
PermissionSet = #PermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curSubject = #curSubject env,
|
||||
curRole = #curRole env,
|
||||
curSuperrole = SOME s,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env } : environment
|
||||
in
|
||||
List.map env_from_list_item superroles
|
||||
end
|
||||
|
||||
(* FIXME: in the context of a permission, return the constraints of this permission.
|
||||
* outside of such a context, return all constraints. *)
|
||||
fun foreach_constraint (env:environment)
|
||||
|
|
@ -169,6 +199,7 @@ fun foreach_constraint (env:environment)
|
|||
curPermission = #curPermission env,
|
||||
curSubject = NONE,
|
||||
curRole = #curRole env ,
|
||||
curSuperrole = NONE,
|
||||
curConstraint = SOME c,
|
||||
extension = #extension env } : environment
|
||||
in
|
||||
|
|
@ -185,6 +216,7 @@ fun foreach_permission env
|
|||
curPermission = SOME p,
|
||||
curSubject = NONE,
|
||||
curRole = NONE ,
|
||||
curSuperrole = NONE,
|
||||
curConstraint = NONE ,
|
||||
extension = #extension env } : environment
|
||||
in
|
||||
|
|
@ -197,6 +229,7 @@ fun foreach_subject (env:environment) =
|
|||
PermissionSet = #PermissionSet env,
|
||||
curPermission = NONE,
|
||||
curSubject = SOME s,
|
||||
curSuperrole = NONE,
|
||||
curRole = NONE,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env } : environment
|
||||
|
|
@ -206,6 +239,7 @@ fun foreach_subject (env:environment) =
|
|||
|
||||
|
||||
fun foreach "role_list" env = foreach_role env
|
||||
| foreach "superrole_list" env = foreach_superrole env
|
||||
| foreach "constraint_list" env = foreach_constraint env
|
||||
| foreach "permission_list" env = foreach_permission env
|
||||
| foreach "subject_list" env = foreach_subject env
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
@// assumption: all classifiers are classes
|
||||
|
||||
@openfile generated/securemova/$classifier_package$.mova
|
||||
// generated by su4sml GCG - Generic Code Generator
|
||||
@// generated by su4sml GCG - Generic Code Generator
|
||||
|
||||
@nl@nl
|
||||
(create-security-diagram $classifier_package$ .) @nl
|
||||
|
|
@ -10,8 +10,10 @@
|
|||
|
||||
@foreach role_list
|
||||
(insert-role $classifier_package$ : $role_name$ .) @nl
|
||||
@foreach superrole_list
|
||||
(insert-role-hierarchy $classifier_package$ | $role_name$ <-> $superrole_name$ .) @nl
|
||||
@end
|
||||
@end
|
||||
@// FIXME: (insert-role-hierarchy $classifier_package$ : subrole <-> superrole .)
|
||||
|
||||
@foreach subject_list
|
||||
(insert-user $classifier_package$: $subject_name$ .) @nl
|
||||
|
|
|
|||
144
src/rep_ocl.sml
144
src/rep_ocl.sml
|
|
@ -49,43 +49,43 @@ sig
|
|||
include REP_OCL_TYPE
|
||||
|
||||
datatype OclTerm =
|
||||
Literal of string * OclType (* Literal with type *)
|
||||
| CollectionLiteral of CollectionPart list * OclType (* content with type *)
|
||||
| If of OclTerm * OclType (* condition *)
|
||||
* OclTerm * OclType (* then *)
|
||||
* OclTerm * OclType (* else *)
|
||||
* OclType (* result type *)
|
||||
| AssociationEndCall of OclTerm * OclType (* source *)
|
||||
* Path (* assoc.-enc *)
|
||||
* OclType (* result type *)
|
||||
| AttributeCall of OclTerm * OclType (* source *)
|
||||
* Path (* attribute *)
|
||||
* OclType (* result type *)
|
||||
| OperationCall of OclTerm * OclType (* source *)
|
||||
* Path (* operation *)
|
||||
* (OclTerm * OclType) list (* parameters *)
|
||||
* OclType (* result tupe *)
|
||||
| OperationWithType of OclTerm * OclType (* source *)
|
||||
* string * OclType (* type parameter *)
|
||||
* OclType (* result type *)
|
||||
| Variable of string * OclType (* name with type *)
|
||||
| Let of string * OclType (* variable *)
|
||||
* OclTerm * OclType (* rhs *)
|
||||
* OclTerm * OclType (* in *)
|
||||
| Iterate of (string * OclType) list (* iterator variables *)
|
||||
* string * OclType * OclTerm (* result variable *)
|
||||
* OclTerm * OclType (* source *)
|
||||
* OclTerm * OclType (* iterator body *)
|
||||
* OclType (* result type *)
|
||||
| Iterator of string (* name of iterator *)
|
||||
* (string * OclType) list (* iterator variables *)
|
||||
* OclTerm * OclType (* source *)
|
||||
* OclTerm * OclType (* iterator-body *)
|
||||
* OclType (* result type *)
|
||||
and CollectionPart = CollectionItem of OclTerm * OclType
|
||||
| CollectionRange of OclTerm (* first *)
|
||||
* OclTerm (* last *)
|
||||
* OclType
|
||||
Literal of string * OclType (* Literal with type *)
|
||||
| CollectionLiteral of CollectionPart list * OclType (* content with type *)
|
||||
| If of OclTerm * OclType (* condition *)
|
||||
* OclTerm * OclType (* then *)
|
||||
* OclTerm * OclType (* else *)
|
||||
* OclType (* result type *)
|
||||
| AssociationEndCall of OclTerm * OclType (* source *)
|
||||
* Path (* assoc.-enc *)
|
||||
* OclType (* result type *)
|
||||
| AttributeCall of OclTerm * OclType (* source *)
|
||||
* Path (* attribute *)
|
||||
* OclType (* result type *)
|
||||
| OperationCall of OclTerm * OclType (* source *)
|
||||
* Path (* operation *)
|
||||
* (OclTerm * OclType) list (* parameters *)
|
||||
* OclType (* result tupe *)
|
||||
| OperationWithType of OclTerm * OclType (* source *)
|
||||
* string * OclType (* type parameter *)
|
||||
* OclType (* result type *)
|
||||
| Variable of string * OclType (* name with type *)
|
||||
| Let of string * OclType (* variable *)
|
||||
* OclTerm * OclType (* rhs *)
|
||||
* OclTerm * OclType (* in *)
|
||||
| Iterate of (string * OclType) list (* iterator variables *)
|
||||
* string * OclType * OclTerm (* result variable *)
|
||||
* OclTerm * OclType (* source *)
|
||||
* OclTerm * OclType (* iterator body *)
|
||||
* OclType (* result type *)
|
||||
| Iterator of string (* name of iterator *)
|
||||
* (string * OclType) list (* iterator variables *)
|
||||
* OclTerm * OclType (* source *)
|
||||
* OclTerm * OclType (* iterator-body *)
|
||||
* OclType (* result type *)
|
||||
and CollectionPart = CollectionItem of OclTerm * OclType
|
||||
| CollectionRange of OclTerm (* first *)
|
||||
* OclTerm (* last *)
|
||||
* OclType
|
||||
end
|
||||
|
||||
|
||||
|
|
@ -150,42 +150,42 @@ struct
|
|||
open Rep_OclType
|
||||
|
||||
datatype OclTerm =
|
||||
Literal of string * OclType (* Literal with type *)
|
||||
| CollectionLiteral of CollectionPart list * OclType (* content with type *)
|
||||
| If of OclTerm * OclType (* condition *)
|
||||
* OclTerm * OclType (* then *)
|
||||
* OclTerm * OclType (* else *)
|
||||
* OclType (* result type *)
|
||||
| AssociationEndCall of OclTerm * OclType (* source *)
|
||||
* Path (* assoc.-enc *)
|
||||
* OclType (* result type *)
|
||||
| AttributeCall of OclTerm * OclType (* source *)
|
||||
* Path (* attribute *)
|
||||
* OclType (* result type *)
|
||||
| OperationCall of OclTerm * OclType (* source *)
|
||||
* Path (* operation *)
|
||||
* (OclTerm * OclType) list (* parameters *)
|
||||
* OclType (* result tupe *)
|
||||
| OperationWithType of OclTerm * OclType (* source *)
|
||||
* string * OclType (* type parameter *)
|
||||
* OclType (* result type *)
|
||||
| Variable of string * OclType (* name with type *)
|
||||
| Let of string * OclType (* variable *)
|
||||
* OclTerm * OclType (* rhs *)
|
||||
* OclTerm * OclType (* in *)
|
||||
| Iterate of (string * OclType) list (* iterator variables *)
|
||||
* string * OclType * OclTerm (* result variable *)
|
||||
* OclTerm * OclType (* source *)
|
||||
* OclTerm * OclType (* iterator body *)
|
||||
* OclType (* result type *)
|
||||
| Iterator of string (* name of iterator *)
|
||||
* (string * OclType) list (* iterator variables *)
|
||||
* OclTerm * OclType (* source *)
|
||||
* OclTerm * OclType (* iterator-body *)
|
||||
* OclType (* result type *)
|
||||
Literal of string * OclType (* Literal with type *)
|
||||
| CollectionLiteral of CollectionPart list * OclType (* content with type *)
|
||||
| If of OclTerm * OclType (* condition *)
|
||||
* OclTerm * OclType (* then *)
|
||||
* OclTerm * OclType (* else *)
|
||||
* OclType (* result type *)
|
||||
| AssociationEndCall of OclTerm * OclType (* source *)
|
||||
* Path (* assoc.-enc *)
|
||||
* OclType (* result type *)
|
||||
| AttributeCall of OclTerm * OclType (* source *)
|
||||
* Path (* attribute *)
|
||||
* OclType (* result type *)
|
||||
| OperationCall of OclTerm * OclType (* source *)
|
||||
* Path (* operation *)
|
||||
* (OclTerm * OclType) list (* parameters *)
|
||||
* OclType (* result tupe *)
|
||||
| OperationWithType of OclTerm * OclType (* source *)
|
||||
* string * OclType (* type parameter *)
|
||||
* OclType (* result type *)
|
||||
| Variable of string * OclType (* name with type *)
|
||||
| Let of string * OclType (* variable *)
|
||||
* OclTerm * OclType (* rhs *)
|
||||
* OclTerm * OclType (* in *)
|
||||
| Iterate of (string * OclType) list (* iterator variables *)
|
||||
* string * OclType * OclTerm (* result variable *)
|
||||
* OclTerm * OclType (* source *)
|
||||
* OclTerm * OclType (* iterator body *)
|
||||
* OclType (* result type *)
|
||||
| Iterator of string (* name of iterator *)
|
||||
* (string * OclType) list (* iterator variables *)
|
||||
* OclTerm * OclType (* source *)
|
||||
* OclTerm * OclType (* iterator-body *)
|
||||
* OclType (* result type *)
|
||||
and CollectionPart = CollectionItem of OclTerm * OclType
|
||||
| CollectionRange of OclTerm (* first *)
|
||||
* OclTerm (* last *)
|
||||
| CollectionRange of OclTerm (* first *)
|
||||
* OclTerm (* last *)
|
||||
* OclType
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -156,18 +156,8 @@ fun mkRole (C as Rep.Class c) = Rep.string_of_path (Rep.name_of C)
|
|||
fun mkSubject (C as Rep.Class c) = User (Rep.string_of_path (Rep.name_of C))
|
||||
| mkSubject _ = error ("in mkSubject: argument is not a class")
|
||||
|
||||
fun mkPermission cs (C as Rep.Class c) =
|
||||
let val atts = Rep.attributes_of (Rep.Class c)
|
||||
val att_classifiers = List.mapPartial
|
||||
(fn (Rep_OclType.Classifier p) => SOME (Rep.class_of p cs)
|
||||
| _ => NONE)
|
||||
(map #attr_type atts)
|
||||
val aends = Rep_Core.associationends_of (Rep.Class c)
|
||||
val aend_classifiers = List.mapPartial (fn (Rep_OclType.Classifier p)
|
||||
=> SOME (Rep.class_of p cs)
|
||||
| _ => NONE)
|
||||
(map #aend_type aends)
|
||||
val classifiers = att_classifiers @ aend_classifiers
|
||||
fun mkPermission cs (c as Rep.Class _) =
|
||||
let val classifiers = (Rep.connected_classifiers_of c cs)
|
||||
val role_classes = List.filter (classifier_has_stereotype "secuml.role")
|
||||
classifiers
|
||||
val root_classes = List.filter (fn x => ListEq.overlaps
|
||||
|
|
@ -176,22 +166,19 @@ fun mkPermission cs (C as Rep.Class c) =
|
|||
classifiers
|
||||
val root_resource = hd root_classes
|
||||
handle Empty => error ("in mkPermission: no root resource found "^
|
||||
"for permission "^Rep.string_of_path (Rep.name_of C))
|
||||
"for permission "^Rep.string_of_path (Rep.name_of c))
|
||||
val action_attributes =
|
||||
List.filter (fn x => List.exists
|
||||
(fn y => List.exists
|
||||
(fn z => y= z)
|
||||
(#stereotypes x))
|
||||
Design.action_stereotypes) atts
|
||||
List.filter (fn x => ListEq.overlaps (#stereotypes x) (Design.action_stereotypes))
|
||||
(Rep.attributes_of c)
|
||||
handle ex => (error_msg "could not parse permission attributes"; raise ex)
|
||||
in
|
||||
{ name = (Rep.string_of_path (Rep.name_of C)),
|
||||
{ name = (Rep.string_of_path (Rep.name_of c)),
|
||||
roles = (map (Rep.string_of_path o Rep.name_of) role_classes),
|
||||
(* FIXME: find attached constraints *)
|
||||
constraints = nil,
|
||||
actions = if action_attributes = []
|
||||
then error ("in mkPermission: Permission "^
|
||||
(Rep.string_of_path (Rep.name_of C))^
|
||||
(Rep.string_of_path (Rep.name_of c))^
|
||||
"has no action attributes")
|
||||
else map (Design.parse_action root_resource) action_attributes }
|
||||
end
|
||||
|
|
|
|||
Loading…
Reference in New Issue