started to clean up...
git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@4372 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Jürgen Doser
parent
333a678a48
commit
7bdf56d18c
|
|
@ -29,9 +29,9 @@ sig
|
|||
|
||||
(* specific for BASE_CARTRIDGE *)
|
||||
val model : environment -> Rep_SecureUML_ComponentUML.Model
|
||||
val curClassifier: environment -> Rep.Classifier
|
||||
val curAttribute: environment -> Rep.attribute
|
||||
val curOperation: environment -> Rep.operation
|
||||
val curArgument : environment -> string * Rep_OclType.OclType
|
||||
|
||||
end
|
||||
val curClassifier: environment -> Rep.Classifier option
|
||||
val curAttribute: environment -> Rep.attribute option
|
||||
val curOperation: environment -> Rep.operation option
|
||||
val curArgument : environment -> (string * Rep_OclType.OclType) option
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -23,111 +23,108 @@
|
|||
|
||||
structure Base_Cartridge : BASE_CARTRIDGE =
|
||||
struct
|
||||
(* translation functions *)
|
||||
open Rep_OclType
|
||||
open Rep
|
||||
open Tpl_Parser
|
||||
open Rep_SecureUML_ComponentUML.Security
|
||||
open ComponentUML
|
||||
open Gcg_Helper
|
||||
(* type translation table *)
|
||||
(* translation functions *)
|
||||
(* type translation table *)
|
||||
|
||||
fun oclType2Native t = Rep_OclType.string_of_OclType t
|
||||
|
||||
fun visibility2Native public = "public"
|
||||
| visibility2Native private = "private"
|
||||
| visibility2Native protected = "protected"
|
||||
| visibility2Native package = "package"
|
||||
fun visibility2Native XMI.public = "public"
|
||||
| visibility2Native XMI.private = "private"
|
||||
| visibility2Native XMI.protected = "protected"
|
||||
| visibility2Native XMI.package = "package"
|
||||
|
||||
fun scope2Native ClassifierScope = "ClassifierScope"
|
||||
| scope2Native InstanceScope = "InstanceScope"
|
||||
fun scope2Native XMI.ClassifierScope = "ClassifierScope"
|
||||
| scope2Native XMI.InstanceScope = "InstanceScope"
|
||||
|
||||
|
||||
type environment = {model : Rep_SecureUML_ComponentUML.Model,
|
||||
curClassifier: Classifier,
|
||||
curOperation : operation,
|
||||
curAttribute : attribute,
|
||||
curArgument : string * OclType
|
||||
}
|
||||
curClassifier: Rep_Core.Classifier option,
|
||||
curOperation : Rep_Core.operation option,
|
||||
curAttribute : Rep_Core.attribute option ,
|
||||
curArgument : (string * Rep_OclType.OclType) option
|
||||
}
|
||||
|
||||
(* service functions for other cartridges to have access to the current
|
||||
* list items
|
||||
*)
|
||||
fun model (env : environment) = #model env
|
||||
fun curClassifier (env : environment) = #curClassifier env
|
||||
fun curAttribute (env : environment) = #curAttribute env
|
||||
fun curOperation (env : environment) = #curOperation env
|
||||
fun curArgument (env : environment) = #curArgument env
|
||||
|
||||
fun curClassifier (env : environment) = (#curClassifier env)
|
||||
fun curAttribute (env : environment) = (#curAttribute env)
|
||||
fun curOperation (env : environment) = (#curOperation env)
|
||||
fun curArgument (env : environment) = (#curArgument env)
|
||||
|
||||
fun curClassifier' (env : environment) = Option.valOf((#curClassifier env))
|
||||
fun curAttribute' (env : environment) = Option.valOf((#curAttribute env))
|
||||
fun curOperation' (env : environment) = Option.valOf((#curOperation env))
|
||||
fun curArgument' (env : environment) = Option.valOf((#curArgument env))
|
||||
|
||||
fun initEnv model = { model = model,
|
||||
curClassifier = emptyClassifier,
|
||||
curOperation = emptyOperation,
|
||||
curAttribute = emptyAttribute,
|
||||
curArgument = emptyArgument
|
||||
curClassifier = NONE,
|
||||
curOperation = NONE,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE
|
||||
} : environment
|
||||
|
||||
|
||||
|
||||
fun lookup (env : environment) "classifier_name" = short_name_of (#curClassifier env)
|
||||
| lookup (env : environment) "classifier_package" = if ((#curClassifier env) = emptyClassifier) then (* not in foreach-loop yet *)
|
||||
Rep_OclType.string_of_path (package_of (hd (#1 (#model env))))
|
||||
else
|
||||
Rep_OclType.string_of_path (package_of (#curClassifier env))
|
||||
(* FIX: check for NONEs in arguments environment *)
|
||||
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 (#1 (#model env))))
|
||||
| SOME c => Rep_OclType.string_of_path (Rep.package_of (curClassifier' env)))
|
||||
|
||||
| lookup (env : environment) "classifier_parent" = 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" = name_of_op (#curOperation env)
|
||||
| lookup (env : environment) "operation_result_type"= oclType2Native (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))
|
||||
| lookup _ s = (gcg_warning ("Couldn't lookup \""^s^"\" in base_cartridge.lookup !"); s)
|
||||
| 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))
|
||||
| lookup _ s = (Gcg_Helper.gcg_warning ("Couldn't lookup \""^s^"\" in base_cartridge.lookup !"); s)
|
||||
|
||||
|
||||
|
||||
fun evalCondition (env : environment) "isClass"
|
||||
= (case (#curClassifier env) of (Class{...}) => true
|
||||
= (case (#curClassifier env) of SOME (Rep.Class{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isInterface"
|
||||
= (case (#curClassifier env) of (Interface{...}) => true
|
||||
= (case (#curClassifier env) of SOME (Rep.Interface{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isEnumeration"
|
||||
= (case (#curClassifier env) of (Enumeration{...}) => true
|
||||
= (case (#curClassifier env) of SOME (Rep.Enumeration{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "isPrimitive"
|
||||
= (case (#curClassifier env) of (Primitive{...}) => true
|
||||
= (case (#curClassifier env) of SOME (Rep.Primitive{...}) => true
|
||||
| _ => false)
|
||||
| evalCondition (env : environment) "hasParent"
|
||||
= let val parentName =
|
||||
Rep_OclType.string_of_path (parent_name_of (#curClassifier env))
|
||||
Rep_OclType.string_of_path (Rep.parent_name_of (curClassifier' env))
|
||||
in
|
||||
(parentName <> "OclAny")
|
||||
end
|
||||
| evalCondition (env : environment) "first_classifier" = (#curClassifier env = hd (#1 (#model env)))
|
||||
| evalCondition (env : environment) "first_attribute" = (#curAttribute env = hd (attributes_of (#curClassifier env)))
|
||||
| evalCondition (env : environment) "first_operation" = (#curOperation env = hd (operations_of (#curClassifier env)))
|
||||
| evalCondition (env : environment) "first_argument" = (#curArgument env = hd (arguments_of_op (#curOperation env)))
|
||||
| evalCondition (env : environment) "last_classifier" = (#curClassifier env = List.last (#1 (#model env)))
|
||||
| evalCondition (env : environment) "last_attribute" = (#curAttribute env = List.last (attributes_of (#curClassifier env)))
|
||||
| evalCondition (env : environment) "last_operation" = (#curOperation env = List.last (operations_of (#curClassifier env)))
|
||||
| evalCondition (env : environment) "last_argument" = (#curArgument env = List.last (arguments_of_op (#curOperation env)))
|
||||
| evalCondition (env : environment) "attribute_isPublic" = ((#visibility (#curAttribute env)) = public)
|
||||
| evalCondition (env : environment) "attribute_isPrivate" = ((#visibility (#curAttribute env)) = private)
|
||||
| evalCondition (env : environment) "attribute_isProtected"=((#visibility (#curAttribute env)) = protected)
|
||||
| evalCondition (env : environment) "attribute_isPackage" = ((#visibility (#curAttribute env)) = package)
|
||||
| evalCondition (env : environment) "attribute_isStatic" = ((#scope (#curAttribute env)) = ClassifierScope)
|
||||
| evalCondition (env : environment) "operation_isPublic" = ((#visibility (#curOperation env)) = public)
|
||||
| evalCondition (env : environment) "operation_isPrivate" = ((#visibility (#curOperation env)) = private)
|
||||
| evalCondition (env : environment) "operation_isProtected"=((#visibility (#curOperation env)) = protected)
|
||||
| evalCondition (env : environment) "operation_isPackage" = ((#visibility (#curOperation env)) = package)
|
||||
| evalCondition (env : environment) "operation_isStatic" = ((#scope (#curOperation env)) = ClassifierScope)
|
||||
| evalCondition (env : environment) "first_classifier" = (curClassifier' env = hd (#1 (#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 (#1 (#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_error ("Couldn't evaluate if-condition: "^s^" in base_cartridge.evalCondition")
|
||||
= Gcg_Helper.gcg_error ("Couldn't evaluate if-condition: "^s^" in base_cartridge.evalCondition")
|
||||
|
||||
|
||||
(* fun foreach_classifier: environment -> environment list *)
|
||||
|
|
@ -135,48 +132,48 @@ fun foreach_classifier (env : environment)
|
|||
= let val cl = #1 (#model env);
|
||||
fun env_from_classifier c =
|
||||
{ model = (#model env),
|
||||
curClassifier = c,
|
||||
curOperation = emptyOperation,
|
||||
curAttribute = emptyAttribute,
|
||||
curArgument = emptyArgument
|
||||
curClassifier = SOME c,
|
||||
curOperation = NONE,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE
|
||||
}
|
||||
in
|
||||
List.map env_from_classifier cl
|
||||
end
|
||||
|
||||
fun foreach_attribute (env : environment)
|
||||
= let val attrs = attributes_of (#curClassifier env);
|
||||
= let val attrs = Rep_Core.attributes_of (curClassifier' env);
|
||||
fun env_from_attr a =
|
||||
{ model = #model env,
|
||||
curClassifier = (#curClassifier env),
|
||||
curOperation = emptyOperation,
|
||||
curAttribute = a,
|
||||
curArgument = emptyArgument
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = NONE,
|
||||
curAttribute = SOME a,
|
||||
curArgument = NONE
|
||||
}
|
||||
in
|
||||
List.map env_from_attr attrs
|
||||
end
|
||||
|
||||
fun foreach_operation (env : environment)
|
||||
= let val ops = operations_of (#curClassifier env);
|
||||
= let val ops = Rep_Core.operations_of (curClassifier' env);
|
||||
fun env_from_op operation =
|
||||
{ model = #model env,
|
||||
curClassifier = (#curClassifier env),
|
||||
curOperation = operation,
|
||||
curAttribute = emptyAttribute,
|
||||
curArgument = emptyArgument
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = SOME operation,
|
||||
curAttribute = NONE,
|
||||
curArgument = NONE
|
||||
}
|
||||
in
|
||||
List.map env_from_op ops
|
||||
end
|
||||
fun foreach_argument (env : environment)
|
||||
= let val args = arguments_of_op (#curOperation env);
|
||||
= let val args = Rep_Core.arguments_of_op (curOperation' env);
|
||||
fun env_from_argument arg =
|
||||
{ model = #model env,
|
||||
curClassifier = (#curClassifier env),
|
||||
curOperation = (#curOperation env),
|
||||
curAttribute = emptyAttribute,
|
||||
curArgument = arg
|
||||
curClassifier = SOME (curClassifier' env),
|
||||
curOperation = SOME (curOperation' env),
|
||||
curAttribute = NONE,
|
||||
curArgument = SOME arg
|
||||
}
|
||||
in
|
||||
List.map env_from_argument args
|
||||
|
|
@ -189,7 +186,7 @@ fun foreach "classifier_list" env = foreach_classifier env
|
|||
(* hier muss man das Environment noch etwas umpacken
|
||||
| foreach listType env = map (pack env) (<SuperCartridge>.foreach name (unpack env))
|
||||
*)
|
||||
| foreach s _ = gcg_error ("Couldn't write foreach "^s^" ." ^
|
||||
| foreach s _ = Gcg_Helper.gcg_error ("Couldn't write foreach "^s^" ." ^
|
||||
"\""^s^"\" not defined in base_cartridge.foreach ")
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@ ann
|
|||
in
|
||||
local
|
||||
$(MLTON_ROOT)/basis/basis.mlb
|
||||
../lib/su4sml/src/su4sml-cygwin.mlb
|
||||
in
|
||||
compiler/compiler_ext.sig
|
||||
compiler/mlton.sml
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@
|
|||
functor GCG_Core (C: CARTRIDGE): GCG =
|
||||
struct
|
||||
|
||||
(* FIX: do not open so many structures... *)
|
||||
open Rep
|
||||
open Rep_OclType
|
||||
open Tpl_Parser
|
||||
|
|
@ -139,4 +140,4 @@ fun generate model template
|
|||
end
|
||||
|
||||
|
||||
end
|
||||
end
|
||||
|
|
|
|||
|
|
@ -38,13 +38,14 @@
|
|||
val isInPermission : ComponentUML.Action -> Permission -> bool
|
||||
end*) =
|
||||
struct
|
||||
open Rep
|
||||
|
||||
(* open Rep
|
||||
open Rep_OclType
|
||||
open Rep_OclTerm
|
||||
open Rep_SecureUML_ComponentUML.Security
|
||||
open ComponentUML
|
||||
open ComponentUML
|
||||
open XMI_DataTypes
|
||||
|
||||
*)
|
||||
exception GCG_Error
|
||||
|
||||
fun gcg_error s = (print ("Error:"^s^"\n"); raise GCG_Error);
|
||||
|
|
@ -68,7 +69,7 @@ val curry = fn f => fn x => fn y => f (x, y)
|
|||
val uncurry = fn f => fn (x, y) => f x y
|
||||
|
||||
|
||||
|
||||
(*
|
||||
val emptyClassifier = (Primitive({ name=["",""],
|
||||
parent=NONE,
|
||||
operations=[],
|
||||
|
|
@ -105,7 +106,7 @@ val emptyPermission = ({actions = [],
|
|||
} : Permission)
|
||||
val emptyRole = ""
|
||||
val emptyConstraint = (Literal("",DummyT))
|
||||
val emptyResource = (("",[]) : Resource)
|
||||
val emptyResource = (ComponentUML.EntityMethod emptyOperation : Resource)
|
||||
val emptyAction = SimpleAction("", emptyResource)
|
||||
|
||||
val emptyModel = (nil, {config_type = "",
|
||||
|
|
@ -113,23 +114,22 @@ val emptyModel = (nil, {config_type = "",
|
|||
subjects = nil,
|
||||
roles = nil,
|
||||
sa = nil}):Rep_SecureUML_ComponentUML.Model
|
||||
|
||||
*)
|
||||
|
||||
fun isSuffix [] _ = true
|
||||
| isSuffix _ [] = false
|
||||
| isSuffix (h1::t1) (h2::t2) = (h1=h2) andalso (isSuffix t1 t2)
|
||||
|
||||
fun resPath_of a = #2 (resource_of a)
|
||||
(* fun resPath_of a = #2 (resource_of a) *)
|
||||
|
||||
fun actionType_of (SimpleAction (t,_)) = t
|
||||
| actionType_of (CompositeAction (t,_)) = t
|
||||
|
||||
(*
|
||||
fun actionTypes_compatible _ "full_access" = true
|
||||
| actionTypes_compatible "read" "read" = true
|
||||
| actionTypes_compatible "update" "update" = true
|
||||
| actionTypes_compatible _ _ = false
|
||||
|
||||
(* checks if a1 is part of a2 *)
|
||||
*)
|
||||
(* checks if a1 is part of a2
|
||||
fun is_contained_in a1 (a2 as (SimpleAction _)) = (a1 = a2)
|
||||
| is_contained_in a1 a2 = let
|
||||
val p1 = resPath_of a1
|
||||
|
|
@ -138,16 +138,18 @@ fun is_contained_in a1 (a2 as (SimpleAction _)) = (a1 = a2)
|
|||
val at2 = actionType_of a2
|
||||
in
|
||||
(isSuffix p2 p1) andalso (actionTypes_compatible at1 at2)
|
||||
end
|
||||
end *)
|
||||
|
||||
(* fun is_contained_in a1 a2 = (a1 = a2) orelse List.exists (fn x=> x=true)) (List.map (is_contained_in a1) (subordinated_actions a2))) *)
|
||||
fun is_contained_in a1 a2 = (a1 = a2) orelse
|
||||
List.exists (fn x=> x=true) ((List.map (is_contained_in a1) (ComponentUML.subordinated_actions a2)))
|
||||
|
||||
fun isInPermission a (p:Permission) = List.exists (is_contained_in a) (#actions p)
|
||||
fun isInPermission a (p:Rep_SecureUML_ComponentUML.Security.Permission) = List.exists (is_contained_in a) (#actions p)
|
||||
|
||||
fun resource_to_string (s,p) = "("^s^", "^(string_of_path p)^")"
|
||||
|
||||
(* fun resource_to_string (s,p) = "("^s^", "^(string_of_path p)^")"
|
||||
fun action_to_string (SimpleAction (s,r)) = "SimpleAction("^s^", "^(resource_to_string r)^"))"
|
||||
| action_to_string (CompositeAction (s,r)) = "CompositeAction("^s^", "^(resource_to_string r)^"))"
|
||||
|
||||
*)
|
||||
|
||||
|
||||
fun assureDir file = let val dirList = rev (tl (rev (String.tokens (fn c => c = #"/") file)))
|
||||
|
|
|
|||
|
|
@ -34,9 +34,9 @@ sig
|
|||
val foreach : string -> environment -> environment list
|
||||
|
||||
(* specific for SECUREUML_CARTRIDGE *)
|
||||
val curPermissionSet: environment -> Rep_SecureUML_ComponentUML.Security.Permission list
|
||||
val curPermission : environment -> Rep_SecureUML_ComponentUML.Security.Permission
|
||||
val curRole : environment -> string
|
||||
val curConstraint : environment -> Rep_OclTerm.OclTerm
|
||||
val curPermissionSet: environment -> Rep_SecureUML_ComponentUML.Security.Permission list option
|
||||
val curPermission : environment -> Rep_SecureUML_ComponentUML.Security.Permission option
|
||||
val curRole : environment -> string option
|
||||
val curConstraint : environment -> Rep_OclTerm.OclTerm option
|
||||
|
||||
end
|
||||
|
|
|
|||
|
|
@ -26,32 +26,39 @@
|
|||
|
||||
functor SecureUML_Cartridge(SuperCart : BASE_CARTRIDGE) : SECUREUML_CARTRIDGE =
|
||||
struct
|
||||
|
||||
(*
|
||||
open Rep_SecureUML_ComponentUML.Security
|
||||
open ComponentUML
|
||||
open Gcg_Helper
|
||||
open Ocl2String
|
||||
|
||||
*)
|
||||
|
||||
type environment = { curPermissionSet: Permission list,
|
||||
curPermission : Permission,
|
||||
curRole : string,
|
||||
curConstraint : Rep_OclTerm.OclTerm,
|
||||
type environment = { curPermissionSet: Rep_SecureUML_ComponentUML.Security.Permission list option,
|
||||
curPermission : Rep_SecureUML_ComponentUML.Security.Permission option,
|
||||
curRole : string option,
|
||||
curConstraint : Rep_OclTerm.OclTerm option,
|
||||
extension : SuperCart.environment }
|
||||
|
||||
|
||||
(* service functions for other cartridges to have access to the current
|
||||
* list items
|
||||
* FIX: check for NONE's
|
||||
*)
|
||||
fun curPermissionSet (env : environment) = #curPermissionSet env
|
||||
fun curPermission (env : environment) = #curPermission env
|
||||
fun curRole (env : environment) = #curRole env
|
||||
fun curConstraint (env : environment) = #curConstraint env
|
||||
fun curPermissionSet (env : environment) = (#curPermissionSet env)
|
||||
fun curPermission (env : environment) = (#curPermission env)
|
||||
fun curRole (env : environment) = (#curRole env)
|
||||
fun curConstraint (env : environment) = (#curConstraint env)
|
||||
|
||||
fun curPermissionSet' (env : environment) = Option.valOf (#curPermissionSet 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 initEnv model = { curPermissionSet = [],
|
||||
curPermission = emptyPermission,
|
||||
curRole = emptyRole,
|
||||
curConstraint = emptyConstraint,
|
||||
fun initEnv model = { curPermissionSet = NONE,
|
||||
curPermission = NONE,
|
||||
curRole = NONE,
|
||||
curConstraint = NONE,
|
||||
extension = SuperCart.initEnv model } : environment
|
||||
|
||||
(* unpack : environment -> SuperCart.environment *)
|
||||
|
|
@ -68,48 +75,46 @@ fun pack (env: environment) (new_env : SuperCart.environment)
|
|||
|
||||
(* Helper functions that get the SuperCartridge's needed environment values *)
|
||||
fun getModel (env : environment) = SuperCart.model (unpack env)
|
||||
fun getCurClassifier (env : environment) = SuperCart.curClassifier (unpack env)
|
||||
fun getCurAttribute (env : environment) = SuperCart.curAttribute (unpack env)
|
||||
fun getCurOperation (env : environment) = SuperCart.curOperation (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)
|
||||
|
||||
type permissionContext = {permissions : Permission list,
|
||||
setter_permissions : Permission list,
|
||||
getter_permissions : Permission list,
|
||||
constructor_permissions : Permission list,
|
||||
destructor_permissions : Permission list}
|
||||
type permissionContext = {permissions : Rep_SecureUML_ComponentUML.Security.Permission list,
|
||||
setter_permissions : Rep_SecureUML_ComponentUML.Security.Permission list,
|
||||
getter_permissions : Rep_SecureUML_ComponentUML.Security.Permission list,
|
||||
constructor_permissions : Rep_SecureUML_ComponentUML.Security.Permission list,
|
||||
destructor_permissions : Rep_SecureUML_ComponentUML.Security.Permission list}
|
||||
|
||||
fun permissionsForAction (e : environment) a
|
||||
= List.filter (isInPermission a) (#permissions (#2 (getModel e)))
|
||||
= List.filter (Gcg_Helper.isInPermission a) (#permissions (#2 (getModel e)))
|
||||
|
||||
(* computePermissionContext: environment -> permissionContext
|
||||
* compute Permissions according to actual environment
|
||||
*)
|
||||
fun computePermissionContext (env : environment)=
|
||||
let
|
||||
fun path_of_attr () = (Rep_Core.name_of (getCurClassifier env))@[#name (getCurAttribute env)]
|
||||
fun path_of_op () = (Rep_Core.name_of (getCurClassifier env))@[(name_of_op (getCurOperation env))]
|
||||
fun getAction "set" = SimpleAction ("update", ("EntityAttribute",(path_of_attr ())))
|
||||
| getAction "get" = SimpleAction ("read", ("EntityAttribute",(path_of_attr ())))
|
||||
| getAction "execute" = SimpleAction ("execute", ("EntityMethod",(path_of_op ())))
|
||||
| getAction "create" = SimpleAction ("create", ("Entity",(Rep_Core.name_of (getCurClassifier env))))
|
||||
| getAction "delete" = SimpleAction ("delete", ("Entity",(Rep_Core.name_of (getCurClassifier env))))
|
||||
| getAction s = gcg_error ("invalid action_type \""^s^"\" in secureUML_cartridge.computePermissionContext:getAction.")
|
||||
fun getAction "set" = ComponentUML.SimpleAction ("update", (ComponentUML.EntityAttribute (Option.valOf(curAttribute env))))
|
||||
| getAction "get" = ComponentUML.SimpleAction ("read", (ComponentUML.EntityAttribute (Option.valOf(curAttribute env))))
|
||||
| getAction "execute" = ComponentUML.SimpleAction ("execute", (ComponentUML.EntityMethod (Option.valOf(curOperation env))))
|
||||
| getAction "create" = ComponentUML.SimpleAction ("create", (ComponentUML.Entity (Option.valOf(curClassifier env))))
|
||||
| getAction "delete" = ComponentUML.SimpleAction ("delete", (ComponentUML.Entity (Option.valOf (curClassifier env))))
|
||||
| getAction s = Gcg_Helper.gcg_error ("invalid action_type \""^s^"\" in secureUML_cartridge.computePermissionContext:getAction.")
|
||||
in
|
||||
if not((getCurAttribute env) = emptyAttribute) then
|
||||
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 not((getCurOperation env) = emptyOperation) then
|
||||
else if Option.isSome(curOperation env) then
|
||||
{permissions = permissionsForAction env (getAction "execute"),
|
||||
setter_permissions = [],
|
||||
getter_permissions = [],
|
||||
constructor_permissions = [],
|
||||
destructor_permissions = []
|
||||
}
|
||||
else if not((getCurClassifier env) = emptyClassifier) then
|
||||
else if Option.isSome(curClassifier env) then
|
||||
{permissions = [],
|
||||
setter_permissions = [],
|
||||
getter_permissions = [],
|
||||
|
|
@ -131,19 +136,19 @@ fun name_of_role r = r
|
|||
(* 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 false (#curConstraint env)
|
||||
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)
|
||||
(* pass the unknown variables to the Superior Cartridge *)
|
||||
| lookup (env : environment) 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)))
|
||||
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)))
|
||||
(* pass unknown condition types to Superior Cartridge *)
|
||||
| evalCondition (env : environment) s = SuperCart.evalCondition (unpack env) s
|
||||
|
||||
|
|
@ -153,10 +158,10 @@ fun evalCondition (env : environment) "first_permission" = (#curPermission env
|
|||
(* fun foreach_<new_list_type>: environment -> environment list *)
|
||||
fun foreach_permission (env : environment)
|
||||
= let val plist = #permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = plist,
|
||||
curPermission = c,
|
||||
curRole = emptyRole ,
|
||||
curConstraint = emptyConstraint,
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
|
|
@ -165,10 +170,10 @@ fun foreach_permission (env : environment)
|
|||
|
||||
fun foreach_readPermission (env : environment)
|
||||
= let val plist = #getter_permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = plist,
|
||||
curPermission = c,
|
||||
curRole = emptyRole ,
|
||||
curConstraint = emptyConstraint,
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
|
|
@ -177,10 +182,10 @@ fun foreach_readPermission (env : environment)
|
|||
|
||||
fun foreach_updatePermission (env : environment)
|
||||
= let val plist = #setter_permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = plist,
|
||||
curPermission = c,
|
||||
curRole = emptyRole ,
|
||||
curConstraint = emptyConstraint,
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
|
|
@ -188,10 +193,10 @@ fun foreach_updatePermission (env : environment)
|
|||
end
|
||||
fun foreach_createPermission (env : environment)
|
||||
= let val plist = #constructor_permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = plist,
|
||||
curPermission = c,
|
||||
curRole = emptyRole ,
|
||||
curConstraint = emptyConstraint,
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
|
|
@ -200,10 +205,10 @@ fun foreach_createPermission (env : environment)
|
|||
|
||||
fun foreach_deletePermission (env : environment)
|
||||
= let val plist = #destructor_permissions (computePermissionContext env);
|
||||
fun env_from_list_item c ={curPermissionSet = plist,
|
||||
curPermission = c,
|
||||
curRole = emptyRole ,
|
||||
curConstraint = emptyConstraint,
|
||||
fun env_from_list_item c ={curPermissionSet = SOME plist,
|
||||
curPermission = SOME c,
|
||||
curRole = NONE ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
|
|
@ -211,11 +216,11 @@ fun foreach_deletePermission (env : environment)
|
|||
end
|
||||
|
||||
fun foreach_role (env : environment)
|
||||
= let val roles = #roles (#curPermission env);
|
||||
= let val roles = #roles (curPermission' env);
|
||||
fun env_from_list_item r ={curPermissionSet = #curPermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = r ,
|
||||
curConstraint = emptyConstraint,
|
||||
curRole = SOME r ,
|
||||
curConstraint = NONE,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
|
|
@ -223,11 +228,11 @@ fun foreach_role (env : environment)
|
|||
end
|
||||
|
||||
fun foreach_constraint (env : environment)
|
||||
= let val cons = #constraints (#curPermission env);
|
||||
= let val cons = #constraints (curPermission' env);
|
||||
fun env_from_list_item c ={curPermissionSet = #curPermissionSet env,
|
||||
curPermission = #curPermission env,
|
||||
curRole = emptyRole ,
|
||||
curConstraint = c,
|
||||
curRole = NONE ,
|
||||
curConstraint = SOME c,
|
||||
extension = #extension env
|
||||
} : environment
|
||||
in
|
||||
|
|
@ -247,4 +252,4 @@ fun foreach "permission_list" env = foreach_permission env
|
|||
| foreach listType env = map (pack env) (SuperCart.foreach listType (unpack env))
|
||||
|
||||
|
||||
end
|
||||
end
|
||||
|
|
|
|||
|
|
@ -91,14 +91,14 @@ val printTTree = printTplTree ""
|
|||
|
||||
fun isComment s = (String.isPrefix "//" s)
|
||||
|
||||
(* returns the left part of l up to the element where f evaluates to true
|
||||
(** returns the left part of l up to the element where f evaluates to true
|
||||
*)
|
||||
fun itemsUntil f [] = []
|
||||
| itemsUntil f (h::t) = if (f h) then []
|
||||
else h::(itemsUntil f t)
|
||||
|
||||
|
||||
(* splits line into tokens considering handling escaped @ *)
|
||||
(** splits line into tokens considering handling escaped @ *)
|
||||
fun tokenize line = let val l = joinEscapeSplitted "@" (fieldSplit line #"@");
|
||||
in
|
||||
(hd l)::(itemsUntil isComment (tl l))
|
||||
|
|
@ -118,9 +118,9 @@ fun getType l = let val sl = tokenize l
|
|||
end
|
||||
|
||||
|
||||
(*
|
||||
(**
|
||||
* getContent line
|
||||
* returns the content of a line
|
||||
* @return the content of a line
|
||||
*)
|
||||
fun getContent l = let val sl = tokenize l
|
||||
in
|
||||
|
|
@ -141,9 +141,9 @@ fun preprocess s = let val rl = replaceSafely(replaceSafely(cleanLine s,"@nl ","
|
|||
end
|
||||
|
||||
|
||||
(* buildTree
|
||||
* builds the TemplateTree
|
||||
* returns a TemplateTree list
|
||||
(**
|
||||
* builds the TemplateTree.
|
||||
* @return a TemplateTree list
|
||||
*)
|
||||
fun buildTree (SOME line) = let fun getNode ("text",c) = (TextLeaf(c))::(buildTree (readNextLine()))
|
||||
| getNode ("foreach",c) = ForEachNode(c,(buildTree (readNextLine())))::(buildTree (readNextLine()))
|
||||
|
|
@ -165,22 +165,22 @@ fun buildTree (SOME line) = let fun getNode ("text",c) = (TextLeaf(c))::(buil
|
|||
|
||||
fun codegen_env _ = getOpt(OS.Process.getEnv "CODEGEN_HOME",".")
|
||||
|
||||
(* calls the external cpp ( C PreProcessor)
|
||||
(** calls the external cpp ( C PreProcessor)
|
||||
* writes merged template to a file with extension .tmp instead of .tpl
|
||||
* and returns this file
|
||||
*)
|
||||
fun call_cpp file = let (*val targetFile = String.substring (file,0,size file -4) ^".tmp";*)
|
||||
val targetFile = OS.FileSys.tmpName ()
|
||||
in
|
||||
(* (OS.Process.system ("cd $CODEGEN; cpp "^file^" "^targetFile^" -P -C"); *)
|
||||
(OS.Process.system ("cpp "^codegen_env()^"/"^file^" "^targetFile^" -P -C");
|
||||
targetFile)
|
||||
end
|
||||
fun call_cpp file =
|
||||
let (*val targetFile = String.substring (file,0,size file -4) ^".tmp";*)
|
||||
val targetFile = OS.FileSys.tmpName ()
|
||||
val _ = OS.Process.system ("cpp "^codegen_env()^"/"^file^" "^targetFile^" -P -C")
|
||||
in
|
||||
targetFile
|
||||
end
|
||||
|
||||
|
||||
|
||||
(* parse [template-file]
|
||||
* returns the parsed template tree
|
||||
(** parse [template-file]
|
||||
* @return the parsed template tree
|
||||
*)
|
||||
fun parse file = let val mergedTpl = call_cpp file;
|
||||
val u = opentFile mergedTpl;
|
||||
|
|
|
|||
Loading…
Reference in New Issue