acs-permissions-procs.tcl

Does not contain a contract.

Location:
/packages/acs-tcl/tcl/acs-permissions-procs.tcl
File Contents

ad_library {

    Tcl procs for the acs permissioning system.

    @author rhs@mit.edu
    @creation-date 2000-08-17
    @cvs-id $Id: acs-permissions-procs.tcl,v 1.49 2024/09/11 06:15:48 gustafn Exp $

}

namespace eval permission {}
#
# Define cache_p to return boolean value depending on the PermissionCacheP
# kernel parameter on the first call.  The namespace eval is needed to
# make the redefinition work for ttrace.
#
ad_proc -private permission::cache_p {} {
    Check, if permission_p caching is enabled or disabled.
    By default caching is disabled.

    @return Boolean value expressing whether permission caching is enabled
} {
    set cache_p [parameter::get \
                     -package_id $::acs::kernel_id \
                     -parameter PermissionCacheP \
                     -default 0]
    namespace eval ::permission [list proc cache_p {} "return $cache_p"]
    return $cache_p
}

d_proc -public permission::grant {
    {-party_id:required}
    {-object_id:required}
    {-privilege:required}
} {
    grant privilege Y to party X on object Z
} {
    db_exec_plsql grant_permission {}
    permission::cache_flush -party_id $party_id -object_id $object_id -privilege $privilege
}

d_proc -public permission::revoke {
    {-party_id:required}
    {-object_id:required}
    {-privilege:required}
} {
    revoke privilege Y from party X on object Z
} {
    db_exec_plsql revoke_permission {}
    permission::cache_flush -party_id $party_id -object_id $object_id -privilege $privilege
}

# args to permission_p and permission_p_no_cache must match
d_proc -public permission::permission_p {
    {-no_login:boolean}
    {-no_cache:boolean}
    {-party_id ""}
    {-object_id:required}
    {-privilege:required}
} {
    Does the provided party have the requested privilege on the given object?

    @param no_cache force loading from db even if cached (flushes cache as well)

    @param no_login Don't bump to registration to refresh authentication, if the user's authentication is expired.
                    This is specifically required in the case where you're calling this from the proc that gets
                    the login page.

    @param party_id if null then it is the current user_id

    @param object_id The object you want to check permissions on.

    @param privilege The privilege you want to check for.

    @return Boolean value expressing if the user has the required privilege on the given object
} {
    if { $party_id eq "" } {
        set party_id [ad_conn user_id]
    }

    set caching_activated [permission::cache_p]

    if { $no_cache_p || !$caching_activated } {
        #
        # No caching wanted (either per-call or configured)
        #
        if { $no_cache_p } {
            #
            # Avoid all caches.
            #
            permission::permission_thread_cache_flush
        }

        if {$caching_activated} {
            #
            # Only flush the cache, when caching is activated.
            # Frequent cache flushing can cause a flood of
            # intra-server talk in a cluster configuration (see bug
            # #2398);
            #
            permission::cache_flush \
                -party_id $party_id \
                -object_id $object_id \
                -privilege $privilege
        }

        set permission_p [permission::permission_p_not_cached \
                              -party_id $party_id \
                              -object_id $object_id \
                              -privilege $privilege]
    } else {
        #
        # Permission caching is activated
        #
        set permission_p [permission::cache_eval \
                              -party_id $party_id \
                              -object_id $object_id \
                              -privilege $privilege]
    }

    if {
        !$no_login_p
        && $party_id == 0
        && [ad_conn user_id] == 0
        && [ad_conn untrusted_user_id] != 0
        && ![string is true -strict $permission_p]
    } {
        #
        # In case, permission was granted above, the party and ad_conn
        # user_id are 0, and the permission is NOT granted based on
        # the untrusted_user_id, require login unless this is
        # deactivated for this call.
        #
        set untrusted_permission_p [permission_p_not_cached \
                                        -party_id [ad_conn untrusted_user_id] \
                                        -object_id $object_id \
                                        -privilege $privilege]
        if { $permission_p != $untrusted_permission_p } {
            # Bump to registration page
            ns_log Debug "permission_p: party_id=$party_id ([acs_object_name $party_id])," \
                "object_id=$object_id ([acs_object_name $object_id])," \
                "privilege=$privilege. Result=>$permission_p." \
                "Untrusted-Result=>$untrusted_permission_p\n[ad_get_tcl_call_stack]"
            if { ![ad_login_page] } {
                auth::require_login
            }
        }
    }

    return $permission_p
}


d_proc -private permission::permission_p_not_cached {
    {-no_cache:boolean}
    {-party_id ""}
    {-object_id:required}
    {-privilege:required}
} {
    does party X have privilege Y on object Z

    This function accepts "-no_cache" just to match the permission_p
    signature since we alias it to permission::permission_p when
    caching is disabled.

    @see permission::permission_p
} {
    if { $party_id eq "" } {
        set party_id [ad_conn user_id]
    }

    # We have a per-request cache here
    return [acs::per_request_cache eval -key acs-tcl.permission_p__cache-$party_id,$object_id,$privilege {
        db_string select_permission_p {
            select acs_permission.permission_p(:object_id, :party_id, :privilege) from dual
        }
    }]
}


ad_proc -private permission::permission_thread_cache_flush {} {
    Flush thread cache
} {
    acs::per_request_cache flush -pattern acs-tcl.permission_p__cache*
}

d_proc -public permission::require_permission {
    {-party_id ""}
    {-object_id:required}
    {-privilege:required}
} {
    require that party X have privilege Y on object Z
} {
    if {$party_id eq ""} {
        set party_id [ad_conn user_id]
    }

    if {![permission_p -party_id $party_id -object_id $object_id -privilege $privilege]} {

        if {!$party_id && ![ad_conn ajax_p]} {
            auth::require_login
        } else {
            set message [string cat "permission::require_permission: " \
                             "$party_id doesn't have privilege $privilege " \
                             "on object '$object_id'"]
            if {$object_id eq ""} {
                ad_log error $message
            } else {
                ns_log notice $message
            }
            ad_return_forbidden \
                "Permission Denied" \
                "You don't have permission to $privilege on object $object_id."
        }

        ad_script_abort
    }
}

d_proc -public permission::inherit_p {
    {-object_id:required}
} {
    Does this object inherit permissions?
    @return Boolean value expression whether permussions are inherited.
} {
    return [db_string select_inherit_p {} -default 0]
}

d_proc -public permission::toggle_inherit {
    {-object_id:required}
} {
    toggle whether or not this object inherits permissions from its parent
} {
    db_dml toggle_inherit {}
    permission::permission_thread_cache_flush
}

d_proc -public permission::set_inherit {
    {-object_id:required}
} {
    set inherit to true
} {
    db_dml set_inherit {}
    permission::permission_thread_cache_flush
}

d_proc -public permission::set_not_inherit {
    {-object_id:required}
} {
    set inherit to false
} {
    db_dml set_not_inherit {}
    permission::permission_thread_cache_flush
}

d_proc -public permission::write_permission_p {
    {-object_id:required}
    {-party_id ""}
    {-creation_user ""}
} {
    Returns whether a party is allowed to edit an object.
    The logic is that this party must have either write permission,
    or it must be the one who created the object.

    @param object_id     The object you want to check write permissions for.

    @param party_id      The party to have or not have write permission.

    @param creation_user Optionally specify creation_user directly as an optimization.
                         Otherwise a query will be executed.

    @return Boolean value expressing if the user has permission to edit the object

    @see permission::require_write_permission
} {
    if { $party_id eq "" } {
        set party_id [ad_conn user_id]
    }
    if { $creation_user eq "" } {
        set creation_user [acs_object::get_element -object_id $object_id -element creation_user]
    }
    if { $party_id == $creation_user } {
        return 1
    }
    if { [permission::permission_p -privilege write -object_id $object_id -party_id $party_id] } {
        return 1
    }
    return 0
}

d_proc -public permission::require_write_permission {
    {-object_id:required}
    {-creation_user ""}
    {-party_id ""}
    {-action "edit"}
} {
    If the user is not allowed to edit this object, returns a permission denied page.

    @param creation_user Optionally specify creation_user directly as an optimization.
                         Otherwise a query will be executed.
    @param party_id      The party to have or not have write permission.

    @see permission::write_permission_p
} {
    if { ![permission::write_permission_p -object_id $object_id -party_id $party_id] } {
        ad_return_forbidden  "Permission Denied"  "You don't have permission to $action this object."
        ad_script_abort
    }
}

d_proc -public permission::get_parties_with_permission {
    {-object_id:required}
    {-privilege "admin"}
} {
    Return a list of lists of party_id and acs_object.title,
    having a given privilege on the given object

    @param object_id
    @param privilege

    @see permission::permission_p
} {
    return [db_list_of_lists get_parties {}]
}


d_proc -private permission::cache_eval {
    {-party_id}
    {-object_id}
    {-privilege}
} {
    Run permission call and cache the result.

    @param party_id
    @param object_id
    @param privilege

    @see permission::permission_p
} {
    return [acs::permission_cache eval \
                -partition_key $party_id \
                -expires [parameter::get -package_id $::acs::kernel_id \
                              -parameter PermissionCacheTimeout \
                              -default 300] \
                $party_id/$object_id/$privilege {
                    permission::permission_p_not_cached \
                        -party_id $party_id \
                        -object_id $object_id \
                        -privilege $privilege
                }]
}

#
# flush permission cache
#

d_proc -public permission::cache_flush {
    {-party_id}
    {-object_id}
    {-privilege}
} {

    Flush permissions from the cache. Either specify all three
    parameters or only party_id

    @param party_id
    @param object_id
    @param privilege

    @see permission::permission_p
} {
    permission::permission_thread_cache_flush

    if {[namespace which ::acs::permission_cache] eq ""} {
        return

    } elseif {[info exists party_id] && [info exists object_id] && [info exists privilege]} {
        #
        # All three attributes are provided
        #
        ::acs::permission_cache flush -partition_key $party_id $party_id/$object_id/$privilege

    } elseif {[info exists party_id] } {
        #
        # At least the party_id is provided
        #
        ::acs::permission_cache flush_all -partition_key $party_id
    } else {
        #
        # tell user, what's implemented
        #
        error "either specify party_id, object_id and privilege, or only party_id"
    }
}



# Local variables:
#    mode: tcl
#    tcl-indent-level: 4
#    indent-tabs-mode: nil
# End:
acs-permissions-procs.tcl

Related Files

File Contents
