Index: openacs-4/packages/xotcl-core/xotcl-core.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v diff -u -r1.23 -r1.24 --- openacs-4/packages/xotcl-core/xotcl-core.info 19 Feb 2007 10:03:35 -0000 1.23 +++ openacs-4/packages/xotcl-core/xotcl-core.info 9 Mar 2007 11:02:55 -0000 1.24 @@ -8,10 +8,10 @@ t xotcl - + Gustaf Neumann XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes) - 2007-02-19 + 2007-03-09 This component contains some core functionality for OACS applications using XOTcl. It includes XOTcl thread handling for OACS (supporting persistent and @@ -30,11 +30,13 @@ 0.41: supporting storage_type file, on_submit method and html for forms; 0.43: context and connection context; 0.44: use connection_context, sch regression test works; -0.45: xo:db require operations; +0.45: xo:db require operations; +0.48: policies + BSD-Style 0 - + Index: openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl,v diff -u -r1.10 -r1.11 --- openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 15 Sep 2006 16:33:06 -0000 1.10 +++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 9 Mar 2007 11:02:56 -0000 1.11 @@ -177,7 +177,7 @@ } Table instproc render_with {renderer trn_mixin} { - #my log "--" + #my log "-- renderer=$renderer" set cl [self class] [self] mixin ${cl}::$renderer foreach child [$cl info classchildren] { @@ -321,6 +321,9 @@ -instproc init_renderer {} { #my log "--" my set __rowcount 0 + my set css.table-class list + my set css.tr.even-class list-even + my set css.tr.odd-class list-odd } TABLE instproc render-actions {} { @@ -350,7 +353,10 @@ html::tr {html::td { html::t [my set no_data]}} } else { foreach line [my children] { - html::tr -class [expr {[my incr __rowcount]%2 ? "list-odd" : "list-even" }] { + #my log "--LINE vars=[my info vars] cL: [[self class] info vars] r=[my renderer]" + html::tr -class [expr {[my incr __rowcount]%2 ? + [my set css.tr.odd-class] : + [my set css.tr.even-class] }] { foreach field [[self]::__columns children] { html::td [concat [list class list] [$field html]] { $field render-data $line @@ -363,7 +369,7 @@ TABLE instproc render {} { if {![my isobject [self]::__actions]} {my actions {}} - html::table -class list { + html::table -class [my set css.table-class] { my render-actions my render-body } @@ -475,7 +481,7 @@ html::div { my render-actions html::div -class table { - html::table -class list {my render-body} + html::table -class [my set css.table-class] {my render-body} } } } @@ -484,7 +490,20 @@ Class create TABLE2::Field -superclass TABLE::Field Class create TABLE2::AnchorField -superclass TABLE::AnchorField Class create TABLE2::ImageField -superclass TABLE::ImageField - + + Class TABLE3 \ + -superclass TABLE2 \ + -instproc init_renderer {} { + next + my set css.table-class list-tiny + my set css.tr.even-class even + my set css.tr.odd-class odd + } + + Class create TABLE3::Action -superclass TABLE::Action + Class create TABLE3::Field -superclass TABLE::Field + Class create TABLE3::AnchorField -superclass TABLE::AnchorField + Class create TABLE3::ImageField -superclass TABLE::ImageField } Class TableWidget \ Index: openacs-4/packages/xotcl-core/tcl/context-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/context-procs.tcl,v diff -u -r1.10 -r1.11 --- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 7 Mar 2007 19:13:05 -0000 1.10 +++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 9 Mar 2007 11:02:56 -0000 1.11 @@ -50,6 +50,7 @@ } # get the query parameters (from the url) + #my log "--P processing actual query $actual_query" foreach querypart [split $actual_query &] { set name_value_pair [split $querypart =] set att_name [ns_urldecode [lindex $name_value_pair 0]] Index: openacs-4/packages/xotcl-core/tcl/generic-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/generic-procs.tcl,v diff -u -r1.45 -r1.46 --- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 19 Feb 2007 10:03:35 -0000 1.45 +++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 9 Mar 2007 11:02:56 -0000 1.46 @@ -848,7 +848,39 @@ return [t1 asHTML] } + # + # Object specific privilege to be used with policies + # + + CrItem ad_instproc privilege=creator { + {-login true} user_id package_id + } { + + Define an object specific privilege to be used in the policies. + Grant access to a content item for the creator (creation_user) + of the item, and for the package admin. + + } { + set allowed 0 + my log "--checking privilege [self args]" + if {[my exists creation_user]} { + if {$user_id == 0 && $login} { + auth::require_login + } elseif {[my set creation_user] == $user_id} { + set allowed 1 + } else { + # allow the package admin always access + set allowed [::xo::cc permission \ + -object_id $package_id \ + -party_id $user_id \ + -privilege admin] + } + } + return $allowed + } + + # # Form template class # Index: openacs-4/packages/xotcl-core/tcl/policy-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/policy-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/tcl/policy-procs.tcl 9 Mar 2007 11:02:56 -0000 1.1 @@ -0,0 +1,164 @@ +ad_library { + XOTcl API for policies + + @author Gustaf Neumann + @creation-date 2007-03-09 + @cvs-id $Id: policy-procs.tcl,v 1.1 2007/03/09 11:02:56 gustafn Exp $ +} + +namespace eval ::xo { + + Class Policy + + Policy instproc defined_methods {class} { + set c [self]::$class + expr {[my isclass $c] ? [$c array names require_permission] : [list]} + } + + Policy instproc check_privilege {{-login true} privilege object method} { + set allowed -1 ;# undecided + if {[acs_user::site_wide_admin_p]} { + return 1 + } + switch $privilege { + none {return 1} + login { + if {$login} { + auth::require_login; return 1 + } else { + return [expr {[::xo::cc user_id] != 0}] + } + } + swa { + set allowed 0 + #if {!$allowed} { + # ad_return_warning "Insufficient Permissions" \ + # "Only side wide admins are allowed for this operation! ($object $method)" + # ad_script_abort + #} + } + default { + # try object specific privileges. These have the signature: + # + # instproc privilege= {{-login true} user_id package_id} + # + if {[$object info methods privilege=$privilege] ne ""} { + set allowed [$object privilege=$privilege \ + -login $login [::xo::cc user_id] [::xo::cc package_id]] + } + } + } + #my log "--check_privilege {$privilege $object $method} ==> $allowed" + return $allowed + } + + Policy instproc get_privilege {permission object method} { + # the privilege might by primitive (one word privilege) + # or it might be complex (attribute + privilege) + # or it might be conditional (primitive or complex) in a list of privilges + + foreach p $permission { + + set condition [lindex $p 0] + if {[llength $condition]>1} { + # we have a condition + if {[eval $object condition $method $condition]} { + # the condition is true + #my log "--c check cond=$condition == TRUE" + return [my get_privilege [lrange $p 1 end] $object $method] + } + } else { + # we have no condition + return [list [expr {[llength $p] == 1 ? "primitive" : "complex"}] $p] + } + } + } + + Policy ad_instproc check_permissions {object method} { + + This method checks whether the current user is allowed + or not to invoke a method based on the given policy. + This method is purely checking and does not force logins + or other side effects. It can be safely used for example + to check whether links should be shown or not. + + @see enforce_permissions + @return 0 or 1 + + } { + foreach class [concat [$object info class] [[$object info class] info heritage]] { + set c [self]::[namespace tail $class] + if {![my isclass $c]} continue + set key require_permission($method) + if {[$c exists $key]} { + set permission [$c set $key] + + foreach {kind p} [my get_privilege $permission $object $method] break + switch $kind { + primitive {return [my check_privilege -login false $p $object $method]} + complex { + foreach {attribute privilege} $p break + set id [$object set $attribute] + my log "--p checking permission::permission_p -object_id $id -privilege $privilege" + return [::xo::cc permission -object_id $id -privilege $privilege \ + -party_id [xo::cc user_id]] + } + } + } + } + return 0 + } + + Policy ad_instproc enforce_permissions {object method} { + + This method checks whether the current user is allowed + or not to invoke a method based on the given policy and + forces logins if required. + + @see check_permissions + @return 0 or 1 + + } { + #my log "--p enforce_permissions {$object $method}" + set allowed 0 + foreach class [concat [$object info class] [[$object info class] info heritage]] { + set c [self]::[namespace tail $class] + if {![my isclass $c]} continue + set key require_permission($method) + if {[$c exists $key]} { + set permission [$c set $key] + + foreach {kind p} [my get_privilege $permission $object $method] break + switch $kind { + primitive { + set allowed [my check_privilege $p $object $method] + set privilege $p + break + } + complex { + foreach {attribute privilege} $p break + set id [$object set $attribute] + set allowed [::xo::cc permission -object_id $id \ + -privilege $privilege \ + -party_id [xo::cc user_id]] + break + } + } + } + } + + #my log "--p enforce_permissions {$object $method} ==> $allowed" + + if {!$allowed} { + ns_log notice "permission::require_permission: [::xo::cc user_id] doesn't \ + have $privilege on $object" + ad_return_forbidden "Permission Denied" "
+ You don't have sufficient permissions for $method on this object ($object). +
" + ad_script_abort + } + + return $allowed + } + +} \ No newline at end of file Index: openacs-4/packages/xotcl-core/www/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/index.tcl,v diff -u -r1.4 -r1.5 --- openacs-4/packages/xotcl-core/www/index.tcl 7 Jan 2007 21:35:38 -0000 1.4 +++ openacs-4/packages/xotcl-core/www/index.tcl 9 Mar 2007 11:02:56 -0000 1.5 @@ -64,7 +64,7 @@ append output "
  • [::xotcl::api object_link {} $cl]
      " - foreach kind {class superclass mixin instmixin} { + foreach kind {class superclass subclass mixin instmixin} { append output [info_classes $cl $kind] }