type-checking and running, but producing wrong results...
git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@4520 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Jürgen Doser
parent
287aef041a
commit
9fb8dba9f1
|
|
@ -100,36 +100,32 @@ fun initEnv model = { model = model,
|
|||
* attribute_scope, operation_name, operation_result_type,
|
||||
* operation_visibility, operation_scope, argument_name, argument_type
|
||||
*)
|
||||
fun lookup (env : environment) "classifier_name"
|
||||
= Rep_Core.short_name_of (curClassifier' env)
|
||||
| lookup (env : environment) "classifier_package"
|
||||
= (case (#curClassifier env) of
|
||||
NONE => Rep_OclType.string_of_path (Rep.package_of (hd (#model env)))
|
||||
| SOME c => Rep_OclType.string_of_path
|
||||
(Rep.package_of (curClassifier' env)))
|
||||
| lookup (env : environment) "classifier_parent"
|
||||
= Rep_Core.short_parent_name_of (curClassifier' env)
|
||||
| lookup (env : environment) "attribute_name"
|
||||
= #name (curAttribute' env)
|
||||
| lookup (env : environment) "attribute_type"
|
||||
= oclType2Native (#attr_type (curAttribute' env))
|
||||
| lookup (env : environment) "attribute_visibility"
|
||||
= visibility2Native(#visibility (curAttribute' env))
|
||||
| lookup (env : environment) "attribute_scope"
|
||||
= scope2Native (#scope (curAttribute' env))
|
||||
| lookup (env : environment) "operation_name"
|
||||
= Rep.name_of_op (curOperation' env)
|
||||
| lookup (env : environment) "operation_result_type"
|
||||
= oclType2Native (Rep.result_of_op (curOperation' env))
|
||||
| lookup (env : environment) "operation_visibility"
|
||||
= visibility2Native (#visibility (curOperation' env))
|
||||
| lookup (env : environment) "operation_scope"
|
||||
= scope2Native (#scope (curOperation' env))
|
||||
| lookup (env : environment) "argument_name" = #1 (curArgument' env)
|
||||
| lookup (env : environment) "argument_type"
|
||||
= oclType2Native (#2 (curArgument' env))
|
||||
fun lookup env "classifier_name" = Rep_Core.short_name_of (curClassifier' env)
|
||||
| lookup env "classifier_package" = (case (#curClassifier env) of
|
||||
NONE => Rep_OclType.string_of_path
|
||||
(Rep.package_of
|
||||
(hd (#model env)))
|
||||
| SOME c => Rep_OclType.string_of_path
|
||||
(Rep.package_of
|
||||
(curClassifier' env)))
|
||||
| lookup env "classifier_parent" = Rep_Core.short_parent_name_of
|
||||
(curClassifier' env)
|
||||
| lookup env "attribute_name" = #name (curAttribute' env)
|
||||
| lookup env "attribute_type" = oclType2Native (#attr_type
|
||||
(curAttribute' env))
|
||||
| lookup env "attribute_visibility" = visibility2Native(#visibility
|
||||
(curAttribute' env))
|
||||
| lookup env "attribute_scope" = scope2Native (#scope (curAttribute' env))
|
||||
| lookup env "operation_name" = Rep.name_of_op (curOperation' env)
|
||||
| lookup env "operation_result_type" = oclType2Native (Rep.result_of_op
|
||||
(curOperation' env))
|
||||
| lookup env "operation_visibility" = visibility2Native (#visibility
|
||||
(curOperation' env))
|
||||
| lookup env "operation_scope" = scope2Native (#scope (curOperation' env))
|
||||
| lookup env "argument_name" = #1 (curArgument' env)
|
||||
| lookup env "argument_type" = oclType2Native (#2 (curArgument' env))
|
||||
| lookup _ s = (Gcg_Helper.gcg_warning ("Couldn't lookup \""^s^
|
||||
"\" in base_cartridge.lookup !"); s)
|
||||
"\" in Base_Cartridge.lookup !"); s)
|
||||
|
||||
|
||||
(**
|
||||
|
|
@ -143,63 +139,53 @@ fun lookup (env : environment) "classifier_name"
|
|||
* operation_isPrivate, operation_isProtected, operation_isPackage,
|
||||
* operation_isStatic,
|
||||
*)
|
||||
fun evalCondition (env : environment) "isClass"
|
||||
= (case (#curClassifier env) of SOME (Rep.Class{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isInterface"
|
||||
= (case (#curClassifier env) of SOME (Rep.Interface{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isEnumeration"
|
||||
= (case (#curClassifier env) of SOME (Rep.Enumeration{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isPrimitive"
|
||||
= (case (#curClassifier env) of SOME (Rep.Primitive{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "hasParent"
|
||||
= let val parentName =
|
||||
Rep_OclType.string_of_path (Rep.parent_name_of (curClassifier' env))
|
||||
in
|
||||
(parentName <> "OclAny")
|
||||
end
|
||||
| evalCondition (env : environment) "first_classifier"
|
||||
= (curClassifier' env = hd (#model env))
|
||||
| evalCondition (env : environment) "first_attribute"
|
||||
= (curAttribute' env = hd (Rep_Core.attributes_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "first_operation"
|
||||
= (curOperation' env = hd (Rep_Core.operations_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "first_argument"
|
||||
= (curArgument' env = hd (Rep_Core.arguments_of_op (curOperation' env)))
|
||||
| evalCondition (env : environment) "last_classifier"
|
||||
= (curClassifier' env = List.last (#model env))
|
||||
| evalCondition (env : environment) "last_attribute"
|
||||
= (curAttribute' env = List.last (Rep_Core.attributes_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "last_operation"
|
||||
= (curOperation' env = List.last (Rep_Core.operations_of (curClassifier' env)))
|
||||
| evalCondition (env : environment) "last_argument"
|
||||
= (curArgument' env = List.last (Rep_Core.arguments_of_op (curOperation' env)))
|
||||
| evalCondition (env : environment) "attribute_isPublic"
|
||||
= ((#visibility (curAttribute' env)) = XMI.public)
|
||||
| evalCondition (env : environment) "attribute_isPrivate"
|
||||
= ((#visibility (curAttribute' env)) = XMI.private)
|
||||
| evalCondition (env : environment) "attribute_isProtected"
|
||||
=((#visibility (curAttribute' env)) = XMI.protected)
|
||||
| evalCondition (env : environment) "attribute_isPackage"
|
||||
= ((#visibility (curAttribute' env)) = XMI.package)
|
||||
| evalCondition (env : environment) "attribute_isStatic"
|
||||
= ((#scope (curAttribute' env)) = XMI.ClassifierScope)
|
||||
| evalCondition (env : environment) "operation_isPublic"
|
||||
= ((#visibility (curOperation' env)) = XMI.public)
|
||||
| evalCondition (env : environment) "operation_isPrivate"
|
||||
= ((#visibility (curOperation' env)) = XMI.private)
|
||||
| evalCondition (env : environment) "operation_isProtected"
|
||||
=((#visibility (curOperation' env)) = XMI.protected)
|
||||
| evalCondition (env : environment) "operation_isPackage"
|
||||
= ((#visibility (curOperation' env)) = XMI.package)
|
||||
| evalCondition (env : environment) "operation_isStatic"
|
||||
= ((#scope (curOperation' env)) = XMI.ClassifierScope)
|
||||
| evalCondition (env : environment) s
|
||||
= Gcg_Helper.gcg_error ("Couldn't evaluate if-condition: "^s^
|
||||
" in base_cartridge.evalCondition")
|
||||
fun test env "isClass" = (case (#curClassifier env) of
|
||||
SOME (Rep.Class{...}) => true
|
||||
| _ => false)
|
||||
| test env "isInterface" = (case (#curClassifier env) of
|
||||
SOME (Rep.Interface{...}) => true
|
||||
| _ => false)
|
||||
| test env "isEnumeration" = (case (#curClassifier env) of
|
||||
SOME (Rep.Enumeration{...}) => true
|
||||
| _ => false)
|
||||
| test env "isPrimitive" = (case (#curClassifier env) of
|
||||
SOME (Rep.Primitive{...}) => true
|
||||
| _ => false)
|
||||
| test env "hasParent" = let val parentName =
|
||||
Rep_OclType.string_of_path
|
||||
(Rep.parent_name_of (curClassifier' env))
|
||||
in
|
||||
(parentName <> "OclAny")
|
||||
end
|
||||
| test env "first_classifier" = (curClassifier' env = hd (#model env))
|
||||
| test env "first_attribute" = (curAttribute' env
|
||||
= hd (Rep_Core.attributes_of (curClassifier' env)))
|
||||
| test env "first_operation" = (curOperation' env
|
||||
= hd (Rep_Core.operations_of (curClassifier' env)))
|
||||
| test env "first_argument" = (curArgument' env
|
||||
= hd (Rep_Core.arguments_of_op (curOperation' env)))
|
||||
| test env "last_classifier" = (curClassifier' env = List.last (#model env))
|
||||
| test env "last_attribute" = (curAttribute' env =
|
||||
List.last (Rep_Core.attributes_of
|
||||
(curClassifier' env)))
|
||||
| test env "last_operation" = (curOperation' env =
|
||||
List.last (Rep_Core.operations_of
|
||||
(curClassifier' env)))
|
||||
| test env "last_argument" = (curArgument' env
|
||||
= List.last (Rep_Core.arguments_of_op
|
||||
(curOperation' env)))
|
||||
| test env "attribute_isPublic" = ((#visibility (curAttribute' env)) = XMI.public)
|
||||
| test env "attribute_isPrivate" = ((#visibility (curAttribute' env)) = XMI.private)
|
||||
| test env "attribute_isProtected" = ((#visibility (curAttribute' env)) = XMI.protected)
|
||||
| test env "attribute_isPackage" = ((#visibility (curAttribute' env)) = XMI.package)
|
||||
| test env "attribute_isStatic" = ((#scope (curAttribute' env)) = XMI.ClassifierScope)
|
||||
| test env "operation_isPublic" = ((#visibility (curOperation' env)) = XMI.public)
|
||||
| test env "operation_isPrivate" = ((#visibility (curOperation' env)) = XMI.private)
|
||||
| test env "operation_isProtected" = ((#visibility (curOperation' env)) = XMI.protected)
|
||||
| test env "operation_isPackage" = ((#visibility (curOperation' env)) = XMI.package)
|
||||
| test env "operation_isStatic" = ((#scope (curOperation' env)) = XMI.ClassifierScope)
|
||||
| test env s = Gcg_Helper.gcg_error ("Couldn't evaluate predicate: "^
|
||||
s^" in base_cartridge.test")
|
||||
|
||||
|
||||
(* fun foreach_classifier: environment -> environment list *)
|
||||
|
|
|
|||
|
|
@ -92,9 +92,7 @@ fun lookup (env : environment) "attribute_name_small_letter"
|
|||
|
||||
|
||||
|
||||
fun evalCondition (env : environment) s = SuperCart.evalCondition (unpack env) s
|
||||
|
||||
|
||||
fun test (env : environment) s = SuperCart.test (unpack env) s
|
||||
|
||||
(* no further functionality to add
|
||||
* just unpack the Supercartridge's environment,
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ fun lookup (env : environment) "attribute_name_small_letter"
|
|||
|
||||
|
||||
|
||||
fun evalCondition (env : environment) s = SuperCart.evalCondition (unpack env) s
|
||||
fun test env s = SuperCart.test (unpack env) s
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ sig
|
|||
val lookup : environment -> string -> string
|
||||
|
||||
(** evaluate boolean-valued predicates in the environment by name. *)
|
||||
val evalCondition : environment -> string -> bool
|
||||
val test : environment -> string -> bool
|
||||
|
||||
(**
|
||||
* return a list of environment, where the "current" element
|
||||
|
|
|
|||
|
|
@ -32,8 +32,7 @@ structure Base_Gcg = GCG_Core (Base_Cartridge)
|
|||
structure CSharp_Gcg = GCG_Core (CSharp_Cartridge(Base_Cartridge))
|
||||
|
||||
structure CSharpSecure_Gcg
|
||||
= GCG_Core (CSharp_Cartridge(SecureUML_Cartridge(structure SuperCart=Base_Cartridge;
|
||||
structure D=ComponentUML)))
|
||||
= GCG_Core (CSharp_Cartridge( ComponentUML_Cartridge( SecureUML_Cartridge(structure SuperCart=Base_Cartridge; structure D=ComponentUML))))
|
||||
|
||||
structure CSharp_NET1_Gcg = GCG_Core (CSharp_NET1_Cartridge(Base_Cartridge));
|
||||
structure CSharpSecure_NET1_Gcg = GCG_Core (CSharp_NET1_Cartridge(SecureUML_Cartridge(structure SuperCart=Base_Cartridge; structure D=ComponentUML)));
|
||||
|
|
|
|||
|
|
@ -4,131 +4,105 @@ struct
|
|||
structure Design = ComponentUML
|
||||
|
||||
(* TODO: fill out *)
|
||||
type environment = { extension: SuperCart.environment}
|
||||
type environment = { curPermissionList: SuperCart.Security.Permission list option,
|
||||
curPermission: SuperCart.Security.Permission option,
|
||||
extension: SuperCart.environment}
|
||||
type Model = SuperCart.Model
|
||||
|
||||
(* unpack : environment -> SuperCart.environment *)
|
||||
fun unpack (env : environment) = #extension env
|
||||
|
||||
(* pack : environment -> SuperCart.environment -> environment *)
|
||||
fun pack (env: environment) (new_env : SuperCart.environment) = {extension = new_env}
|
||||
fun pack (env: environment) (new_env : SuperCart.environment) =
|
||||
{ curPermissionList = #curPermissionList env,
|
||||
curPermission = #curPermission env,
|
||||
extension = new_env}
|
||||
|
||||
fun initEnv model = { curPermissionList = NONE,
|
||||
curPermission = NONE,
|
||||
extension = SuperCart.initEnv model}
|
||||
|
||||
fun initEnv model = {extension = SuperCart.initEnv model}
|
||||
fun getModel (env : environment) = SuperCart.getModel (unpack env)
|
||||
fun curClassifier (env : environment) = SuperCart.curClassifier (unpack env)
|
||||
fun curAttribute (env : environment) = SuperCart.curAttribute (unpack env)
|
||||
fun curOperation (env : environment) = SuperCart.curOperation (unpack env)
|
||||
fun curArgument (env : environment) = SuperCart.curArgument (unpack env)
|
||||
|
||||
|
||||
(**
|
||||
* compute the atomic actions that are possible on the currently "active"
|
||||
* resource.
|
||||
* Maybe sme of this should be moved to component_uml.sml...
|
||||
*)
|
||||
fun atomic_actions_from_context env =
|
||||
if Option.isSome(curAttribute env) then
|
||||
let fun make_action s =
|
||||
ComponentUML.SimpleAction (s,
|
||||
ComponentUMLResource.EntityAttribute
|
||||
(Option.valOf (curAttribute env)))
|
||||
in [make_action "read", make_action "update"] end
|
||||
else if Option.isSome(curOperation env) then
|
||||
let fun make_action s =
|
||||
ComponentUML.SimpleAction (s,
|
||||
ComponentUMLResource.EntityMethod
|
||||
(Option.valOf (curOperation env)))
|
||||
in [make_action "execute"] end
|
||||
else if Option.isSome(curClassifier env) then
|
||||
let fun make_action s =
|
||||
ComponentUML.SimpleAction (s,
|
||||
ComponentUMLResource.Entity
|
||||
(Option.valOf (curClassifier env)))
|
||||
in [make_action "create", make_action "delete"] end
|
||||
else []
|
||||
|
||||
(* FIX *)
|
||||
fun permissionsForAction env _ = nil
|
||||
|
||||
(* computePermissionContext: environment -> permissionContext
|
||||
* compute Permissions according to actual environment
|
||||
* FIX: move to ComponentUML cartridge...*)
|
||||
fun computePermissionContext (env : environment)=
|
||||
let
|
||||
fun getAction "set" = ComponentUML.SimpleAction ("update", (ComponentUMLResource.EntityAttribute (Option.valOf(curAttribute env))))
|
||||
| getAction "get" = ComponentUML.SimpleAction ("read", (ComponentUMLResource.EntityAttribute (Option.valOf(curAttribute env))))
|
||||
| getAction "execute" = ComponentUML.SimpleAction ("execute", (ComponentUMLResource.EntityMethod (Option.valOf(curOperation env))))
|
||||
| getAction "create" = ComponentUML.SimpleAction ("create", (ComponentUMLResource.Entity (Option.valOf(curClassifier env))))
|
||||
| getAction "delete" = ComponentUML.SimpleAction ("delete", (ComponentUMLResource.Entity (Option.valOf (curClassifier env))))
|
||||
| getAction s = Gcg_Helper.gcg_error ("invalid action_type \""^s^"\" in secureUML_cartridge.computePermissionContext:getAction.")
|
||||
in
|
||||
if Option.isSome(curAttribute env) then
|
||||
{permissions = [],
|
||||
setter_permissions = (permissionsForAction env (getAction "set")),
|
||||
getter_permissions = (permissionsForAction env (getAction "get")),
|
||||
constructor_permissions = [],
|
||||
destructor_permissions = []
|
||||
}
|
||||
else if Option.isSome(curOperation env) then
|
||||
{permissions = permissionsForAction env (getAction "execute"),
|
||||
setter_permissions = [],
|
||||
getter_permissions = [],
|
||||
constructor_permissions = [],
|
||||
destructor_permissions = []
|
||||
}
|
||||
else if Option.isSome(curClassifier env) then
|
||||
{permissions = [],
|
||||
setter_permissions = [],
|
||||
getter_permissions = [],
|
||||
constructor_permissions = permissionsForAction env (getAction "create"),
|
||||
destructor_permissions = permissionsForAction env (getAction "delete")
|
||||
}
|
||||
else
|
||||
{permissions = SuperCart.Security.getPermissions (#2 (getModel env)),
|
||||
setter_permissions = [],
|
||||
getter_permissions = [],
|
||||
constructor_permissions = [],
|
||||
destructor_permissions = []
|
||||
}
|
||||
end
|
||||
|
||||
fun permissions_for_action env act = nil
|
||||
|
||||
(********** ADDING/MODIFYING VARIABLE SUBSTITUTIONS *****************************************)
|
||||
(* lookup environment -> string -> string
|
||||
* might override some lookup entries of the base cartridge
|
||||
*)
|
||||
fun lookup (env : environment) s = SuperCart.lookup (unpack env) s
|
||||
|
||||
|
||||
fun lookup (env:environment) "permission_name" =
|
||||
let val p = #curPermission env
|
||||
in case p of
|
||||
SOME x => #name x
|
||||
| NONE => SuperCart.lookup (unpack env) "permission_name"
|
||||
end
|
||||
| lookup env s = SuperCart.lookup (unpack env) s
|
||||
|
||||
(********** ADDING IF-CONDITION TYPE *****************************************)
|
||||
fun evalCondition (env : environment) s = SuperCart.evalCondition (unpack env) s
|
||||
(** no cartridge specific predicates are defined (yet). *)
|
||||
fun test env "first_permission" = let val p = #curPermission env
|
||||
in case p of
|
||||
SOME x => x = hd (Option.valOf (#curPermissionList env))
|
||||
| NONE => SuperCart.test (unpack env) "first_permission"
|
||||
end
|
||||
| test env "last_permission" = let val p = #curPermission env
|
||||
in case p of
|
||||
SOME x => x = List.last (Option.valOf (#curPermissionList env))
|
||||
| NONE => SuperCart.test (unpack env) "first_permission"
|
||||
end
|
||||
| test env s = SuperCart.test (unpack env) s
|
||||
|
||||
|
||||
(********** ADDING FOREACH TYPE **********************************************)
|
||||
(*
|
||||
fun foreach_readPermission (env : environment)
|
||||
= let val plist = #getter_permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
List.map env_from_list_item plist
|
||||
end
|
||||
|
||||
fun foreach_updatePermission (env : environment)
|
||||
= let val plist = #setter_permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
List.map env_from_list_item plist
|
||||
end
|
||||
fun foreach_createPermission (env : environment)
|
||||
= let val plist = #constructor_permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
List.map env_from_list_item plist
|
||||
end
|
||||
|
||||
fun foreach_deletePermission (env : environment)
|
||||
= let val plist = #destructor_permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
List.map env_from_list_item plist
|
||||
end
|
||||
*)
|
||||
|
||||
|
||||
fun foreach listType env = map (pack env) (SuperCart.foreach listType (unpack env))
|
||||
|
||||
|
||||
fun foreach_permission env name =
|
||||
let val action = List.find (fn x => ComponentUML.action_type_of x = name)
|
||||
(atomic_actions_from_context env)
|
||||
val permissions = permissions_for_action env action
|
||||
fun env_from_list_item c = { curPermissionList = SOME permissions,
|
||||
curPermission = SOME c,
|
||||
extension = #extension env} : environment
|
||||
in
|
||||
List.map env_from_list_item permissions
|
||||
end
|
||||
|
||||
fun foreach "readPermission_list" env = foreach_permission env "read"
|
||||
| foreach "updatePermission_list" env = foreach_permission env "update"
|
||||
| foreach "createPermission_list" env = foreach_permission env "create"
|
||||
| foreach "deletePermission_list" env = foreach_permission env "delete"
|
||||
| foreach "executePermission_list" env = foreach_permission env "execute"
|
||||
| foreach listType env = map (pack env) (SuperCart.foreach listType (unpack env))
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ fun write env (Tpl_Parser.RootNode(l)) = List.app (write env) l
|
|||
| writeThen _ [Tpl_Parser.ElseNode(_)]= ()
|
||||
| writeThen e (h::t) = (write e h ;writeThen e t)
|
||||
in
|
||||
if (C.evalCondition env cond)
|
||||
if (C.test env cond)
|
||||
then writeThen env l
|
||||
else (case (List.last l) of nd as (Tpl_Parser.ElseNode(_)) => write env nd
|
||||
| _ => () )
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ signature SECUREUML_CARTRIDGE =
|
|||
sig
|
||||
|
||||
(** the particular secureuml dialect used *)
|
||||
structure Security:SECURITY_LANGUAGE
|
||||
structure Security:SECUREUML
|
||||
|
||||
include BASE_CARTRIDGE where
|
||||
type Model = Rep.Classifier list * Security.Configuration
|
||||
|
|
@ -43,6 +43,11 @@ val isInPermission : Security.Design.Action -> Security.Permission -> bool
|
|||
end
|
||||
|
||||
|
||||
(**
|
||||
* A Cartridge that supports the basic SecureUML concepts:
|
||||
* Permissions, Roles, and Constraints.
|
||||
*
|
||||
*)
|
||||
functor SecureUML_Cartridge(structure SuperCart : BASE_CARTRIDGE;
|
||||
structure D: DESIGN_LANGUAGE)
|
||||
: SECUREUML_CARTRIDGE =
|
||||
|
|
@ -107,33 +112,33 @@ fun isInPermission a (p:Security.Permission) = List.exists (is_contained_in a) (
|
|||
|
||||
fun name_of_role r = r
|
||||
|
||||
|
||||
|
||||
(********** ADDING/MODIFYING VARIABLE SUBSTITUTIONS *************************)
|
||||
(* lookup environment -> string -> string
|
||||
* might override some lookup entries of the base cartridge
|
||||
*)
|
||||
fun lookup (env : environment) "permission_name" = #name (curPermission' env)
|
||||
| lookup (env : environment) "role_name" = name_of_role (curRole' env)
|
||||
| lookup (env : environment) "constraint" = Ocl2String.ocl2string false (curConstraint' env)
|
||||
| lookup (env : environment) s = SuperCart.lookup (unpack env) s
|
||||
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 s = SuperCart.lookup (unpack env) s
|
||||
|
||||
(********** ADDING IF-CONDITION TYPE *****************************************)
|
||||
fun evalCondition (env : environment) "first_permission" =
|
||||
(curPermission' env = hd (curPermissionSet' env))
|
||||
| evalCondition (env : environment) "first_role" =
|
||||
(curRole' env = hd (#roles (curPermission' env)))
|
||||
| evalCondition (env : environment) "first_constraint" =
|
||||
(curConstraint' env = hd (#constraints (curPermission' env)))
|
||||
| evalCondition (env : environment) "last_permission" =
|
||||
(curPermission' env = List.last (curPermissionSet' env))
|
||||
| evalCondition (env : environment) "last_role" =
|
||||
(curRole' env = List.last (#roles (curPermission' env)))
|
||||
| evalCondition (env : environment) "last_constraint" =
|
||||
(curConstraint' env = List.last (#constraints (curPermission' env)))
|
||||
| evalCondition (env : environment) s = SuperCart.evalCondition (unpack env) s
|
||||
fun test env "first_permission" = (curPermission' env = hd (curPermissionSet' env))
|
||||
| test env "first_role" = (curRole' env = hd (#roles (curPermission' env)))
|
||||
| test env "first_constraint" = (curConstraint' env
|
||||
= hd (#constraints (curPermission' env)))
|
||||
| test env "last_permission" = (curPermission' env
|
||||
= List.last (curPermissionSet' env))
|
||||
| test env "last_role" = (curRole' env
|
||||
= List.last (#roles (curPermission' env)))
|
||||
| test env "last_constraint" = (curConstraint' env
|
||||
= List.last (#constraints (curPermission' env)))
|
||||
| test env s = SuperCart.test (unpack env) s
|
||||
|
||||
|
||||
(********** ADDING FOREACH TYPE **********************************************)
|
||||
fun foreach_role (env : environment)
|
||||
fun foreach_role env
|
||||
= let val roles = #roles (curPermission' env);
|
||||
fun env_from_list_item r ={ model = #model env,
|
||||
curPermissionSet = #curPermissionSet env,
|
||||
|
|
@ -145,7 +150,7 @@ fun foreach_role (env : environment)
|
|||
List.map env_from_list_item roles
|
||||
end
|
||||
|
||||
fun foreach_constraint (env : environment)
|
||||
fun foreach_constraint env
|
||||
= let val cons = #constraints (curPermission' env);
|
||||
fun env_from_list_item c ={ model = #model env,
|
||||
curPermissionSet = #curPermissionSet env,
|
||||
|
|
@ -157,7 +162,7 @@ fun foreach_constraint (env : environment)
|
|||
List.map env_from_list_item cons
|
||||
end
|
||||
|
||||
fun foreach_permission (env : environment)
|
||||
fun foreach_permission env
|
||||
= let val perms = curPermissionSet' env
|
||||
fun env_from_list_item p ={ model = #model env,
|
||||
curPermissionSet = #curPermissionSet env,
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@ struct
|
|||
open Gcg_Helper
|
||||
|
||||
val tplStream = ref (TextIO.openString "@// dummy template\n");
|
||||
|
||||
fun opentFile file = (TextIO.closeIn (!tplStream) ;
|
||||
print ("opening "^file^"...\n");
|
||||
tplStream := (TextIO.openIn file))
|
||||
|
|
|
|||
|
|
@ -129,8 +129,8 @@ fun parse_action root (att:Rep.attribute) =
|
|||
end
|
||||
handle _ => library.error "in ComponentUML.parse_action: could not parse attribute"
|
||||
|
||||
fun actionType_of (SimpleAction (t,_)) = t
|
||||
| actionType_of (CompositeAction (t,_)) = t
|
||||
fun action_type_of (SimpleAction (t,_)) = t
|
||||
| action_type_of (CompositeAction (t,_)) = t
|
||||
|
||||
(* val action_names = ["create","read","update","delete","full_access","execute"] *)
|
||||
|
||||
|
|
|
|||
|
|
@ -48,6 +48,7 @@ sig
|
|||
|
||||
val actions_of : Resource -> Action list
|
||||
val resource_of: Action -> Resource
|
||||
val action_type_of : Action -> string
|
||||
|
||||
(**
|
||||
* parse a permission attribute into an action.
|
||||
|
|
|
|||
|
|
@ -23,12 +23,46 @@
|
|||
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
******************************************************************************)
|
||||
|
||||
signature SECUREUML =
|
||||
sig
|
||||
structure Design : DESIGN_LANGUAGE
|
||||
|
||||
|
||||
type Configuration
|
||||
type Config_Type = string
|
||||
|
||||
type Role = string
|
||||
type Permission = {name: string,
|
||||
roles: Role list,
|
||||
constraints: Rep_OclTerm.OclTerm list,
|
||||
actions: Design.Action list }
|
||||
|
||||
val getPermissions : Configuration -> Permission list
|
||||
val type_of : Configuration -> Config_Type
|
||||
val is_empty : Configuration -> bool
|
||||
|
||||
type User
|
||||
val name_of : User -> string
|
||||
|
||||
(* a bit unclear, which of the following we really need *)
|
||||
val users_of : Permission -> User list
|
||||
(* val permissions_of : User -> Permission list *)
|
||||
val check_permission: User * Permission -> bool
|
||||
|
||||
val actions_of : Permission -> Design.Action list
|
||||
val permissions_of : Design.Action -> Permission list
|
||||
|
||||
val parse: Rep_Core.Classifier list ->
|
||||
(Rep_Core.Classifier list * Configuration)
|
||||
|
||||
end
|
||||
|
||||
(**
|
||||
* SecureUML is a simple security language based on RBAC.
|
||||
* Permissions relate roles with actions and can be further constrained
|
||||
* using OCL:
|
||||
*)
|
||||
functor SecureUML(structure Design: DESIGN_LANGUAGE):SECURITY_LANGUAGE =
|
||||
functor SecureUML(structure Design: DESIGN_LANGUAGE):SECUREUML =
|
||||
struct
|
||||
|
||||
structure Design : DESIGN_LANGUAGE = Design
|
||||
|
|
@ -119,7 +153,6 @@ fun mkPermission cs (Rep.Class c) =
|
|||
constraints = nil,
|
||||
actions = let
|
||||
val atts = Rep.attributes_of (Rep.Class c)
|
||||
(* val attr_stereotypes = map (hd o #stereotypes) atts *)
|
||||
val root_resource =
|
||||
hd (List.filter (classifier_has_stereotype "compuml.entity")
|
||||
(map (fn (Rep_OclType.Classifier p) =>
|
||||
|
|
|
|||
Loading…
Reference in New Issue