270 lines
12 KiB
Standard ML
270 lines
12 KiB
Standard ML
(*****************************************************************************
|
|
* su4sml --- an SML repository for managing (Secure)UML/OCL models
|
|
* http://projects.brucker.ch/su4sml/
|
|
*
|
|
* secureuml_cartridge.sml --- A cartridge for Access Control features of SecureUML
|
|
* transcribes a su4sml model according to a template
|
|
* tree into code specific to a target language
|
|
* cartridge
|
|
* This file is part of su4sml.
|
|
*
|
|
* Copyright (c) 2005-2007, ETH Zurich, Switzerland
|
|
*
|
|
* All rights reserved.
|
|
*
|
|
* Redistribution and use in source and binary forms, with or without
|
|
* modification, are permitted provided that the following conditions are
|
|
* met:
|
|
*
|
|
* * Redistributions of source code must retain the above copyright
|
|
* notice, this list of conditions and the following disclaimer.
|
|
*
|
|
* * Redistributions in binary form must reproduce the above
|
|
* copyright notice, this list of conditions and the following
|
|
* disclaimer in the documentation and/or other materials provided
|
|
* with the distribution.
|
|
*
|
|
* * Neither the name of the copyright holders nor the names of its
|
|
* contributors may be used to endorse or promote products derived
|
|
* from this software without specific prior written permission.
|
|
*
|
|
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
|
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
|
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
|
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
|
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
******************************************************************************)
|
|
(* $Id$ *)
|
|
|
|
(**
|
|
* A Cartridge that supports the basic SecureUML concepts:
|
|
* Permissions, Roles, and Constraints.
|
|
*)
|
|
signature SECUREUML_CARTRIDGE =
|
|
sig
|
|
|
|
(** the particular secureuml dialect used *)
|
|
structure Security:SECUREUML
|
|
|
|
include BASE_CARTRIDGE where
|
|
(*type Model = Rep.Classifier list * Security.Configuration*)
|
|
type Model = Rep.Model * Security.Configuration
|
|
|
|
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
|
|
|
|
|
|
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 =
|
|
struct
|
|
|
|
structure Security = SecureUML(structure Design = D)
|
|
|
|
(*type Model = Rep.Classifier list * Security.Configuration*)
|
|
type Model = Rep.Model * Security.Configuration
|
|
|
|
type environment = { model : Model,
|
|
PermissionSet : Security.Permission list,
|
|
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,
|
|
PermissionSet = (#permissions (#2 m)),
|
|
curPermission = NONE,
|
|
curSubject = NONE,
|
|
curRole = NONE,
|
|
curSuperrole = NONE,
|
|
curConstraint = NONE,
|
|
extension = SuperCart.initEnv (#1 m) } : environment
|
|
end
|
|
|
|
(* unpack : environment -> SuperCart.environment *)
|
|
fun unpack (env : environment) = #extension env
|
|
|
|
(* pack : environment -> SuperCart.environment -> environment *)
|
|
fun pack (env: environment) (new_env : SuperCart.environment)
|
|
= { model = #model env,
|
|
PermissionSet = #PermissionSet env,
|
|
curSubject = #curSubject env,
|
|
curPermission = #curPermission env,
|
|
curRole = #curRole env,
|
|
curSuperrole = #curSuperrole env,
|
|
curConstraint = #curConstraint env,
|
|
extension = new_env}
|
|
|
|
|
|
(* Helper functions that get the SuperCartridge's needed environment values *)
|
|
fun getModel (env : environment) = #model 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)
|
|
fun curAssociationEnd env = SuperCart.curAssociationEnd (unpack env)
|
|
|
|
|
|
|
|
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 "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 => Logger.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)))
|
|
| test env "first_constraint" = (curConstraint' env = hd (#constraints (curPermission' env)))
|
|
| test env "last_permission" = (curPermission' env = List.last (PermissionSet 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 **********************************************)
|
|
(** iterates over roles, depending on the context.
|
|
* in the context of a permission, iterate over all roles which have this permission.
|
|
* in the context of a subject, iterate over all roles of that subject.
|
|
* outside of these contextes, iterate over all roles.
|
|
*)
|
|
fun foreach_role (env:environment)
|
|
= let val roles = case #curPermission env
|
|
of SOME p => #roles p
|
|
| 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,
|
|
PermissionSet = #PermissionSet env,
|
|
curPermission = #curPermission env,
|
|
curSubject = #curSubject env,
|
|
curRole = SOME r ,
|
|
curSuperrole = NONE,
|
|
curConstraint = NONE,
|
|
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 => Logger.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)
|
|
= let val cons = case #curPermission env
|
|
of SOME p => #constraints p
|
|
| NONE => Security.all_constraints (#2 (#model env))
|
|
fun env_from_list_item c ={ model = #model env,
|
|
PermissionSet = #PermissionSet env,
|
|
curPermission = #curPermission env,
|
|
curSubject = NONE,
|
|
curRole = #curRole env ,
|
|
curSuperrole = NONE,
|
|
curConstraint = SOME c,
|
|
extension = #extension env } : environment
|
|
in
|
|
List.map env_from_list_item cons
|
|
end
|
|
|
|
(* FIXME (when possible): in the context of a role, return the permissions of this role.
|
|
* outside of such a context, return all permissions.*)
|
|
|
|
fun foreach_permission env
|
|
= let val perms = PermissionSet env
|
|
fun env_from_list_item p ={ model = #model env,
|
|
PermissionSet = #PermissionSet env,
|
|
curPermission = SOME p,
|
|
curSubject = NONE,
|
|
curRole = NONE ,
|
|
curSuperrole = NONE,
|
|
curConstraint = NONE ,
|
|
extension = #extension env } : environment
|
|
in
|
|
List.map env_from_list_item perms
|
|
end
|
|
|
|
fun foreach_subject (env:environment) =
|
|
let val subjects = (Security.all_subjects o #2 o #model) env
|
|
fun env_from_list_item s = { model = #model env,
|
|
PermissionSet = #PermissionSet env,
|
|
curPermission = NONE,
|
|
curSubject = SOME s,
|
|
curSuperrole = NONE,
|
|
curRole = NONE,
|
|
curConstraint = NONE,
|
|
extension = #extension env } : environment
|
|
in
|
|
List.map env_from_list_item subjects
|
|
end
|
|
|
|
|
|
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
|
|
| foreach listType env = map (pack env) (SuperCart.foreach listType (unpack env))
|
|
|
|
|
|
end
|