tool::define ::clique::hub {
method Clique_Recompute_Hive {} {
my variable recompute_hive
set recompute_hive 1
}
method Clique_Hive {} {
###
# Wipe out elaborated lists
###
my variable recompute_hive linkbit
if {!$recompute_hive} return
set recompute_hive 0
puts [list RECOMPUTE HIVE]
my <db> eval {
drop table if exists porg_hive;
delete from porg_member;
create table if not exists porg_hive (
porgid integer references porg,
linkid integer references link,
queen integer references link default 0,
port string
);
create index if not exists porg_hive_idx on porg_hive (linkid,queen);
}
my <db> eval {
}
my <db> eval {
insert into porg_hive(porgid,port,linkid,queen) select porga,typea,linkid,linkid from link;
insert into porg_hive(porgid,port,linkid,queen) select porgb,typeb,linkid,linkid from link;
}
###
# Do a flat insertion of all direct groups and members
###
set memberbit [my porgword_mask linktypemask member]
set groupbit [my porgword_mask linktypemask group]
my <db> eval {
insert into porg_member(groupid,porgid,accessmask,linktypemask)
select porga,porgb,accessmask,linktypemask from link where (linktypemask & :memberbit);
}
my <db> eval {
insert into porg_member(groupid,porgid,accessmask,linktypemask)
select porgb,porga,accessmask,linktypemask from link where (linktypemask & :groupbit);
}
set changes 1
while {$changes} {
set changes 0
my <db> eval {select porgid,port,linkid,queen from porg_hive} {
if {[my Hive_Expand $porgid $port $linkid $queen]} {
set changes 1
break;
}
}
}
}
method porgword_map map {
set varname porgword_$map
my variable $varname
if {![info exists ${varname}]} {
set ${varname} {}
my <db> eval {select name,bit from porgword where map=:map} {
dict set ${varname} $name [expr {1 << $bit}]
}
}
return [set $varname]
}
method porgword_mask {map args} {
set bitmask [my porgword_map $map]
if {[llength $args]==1} {
set strings [lindex $args 0]
} else {
set strings $args
}
if {"*" in $args} {
set result 0xffff
} else {
set result 0
}
foreach {code mask} $bitmask {
if {"!$code" in $strings} {
set result [expr {$result & ~$mask}]
} elseif {"~$code" in $strings} {
set result [expr {$result & ~$mask}]
} elseif {"-$code" in $strings} {
set result [expr {$result & ~$mask}]
} elseif {$code in $strings} {
set result [expr {$result | $mask}]
}
}
return $result
}
method porgword_list {map word} {
set varname porgword_$map
my variable $varname
if {![info exists ${varname}]} {
set ${varname} {}
my <db> eval {select name,bit from porgword where map=:map} {
dict set ${varname} $name [expr {1 << $bit}]
}
}
set result {}
foreach {code mask} [set ${varname}] {
if {$mask & $word} {
lappend result $code
}
}
return $result
}
###
# Groups are logical sets. One link can belong to more than one group,
# because groups can be parts of other groups.
# Example: Fred is a chairman. The chair is the ultimate authority
# for every group in the organization. Thus Fred is also a member
# of every group in the organization, with executive privilege.
###
method group_add {groupid memberid accessmask} {
set groupid [my porgid $groupid]
set memberid [my porgid $memberid]
if {$groupid eq $memberid} return
if {![my <db> exists {select accessmask from porg_member where groupid=:groupid and porgid=:memberid}]} {
my <db> eval {insert into porg_member(groupid,porgid,accessmask) VALUES (:groupid,:porgid,:accessmask)}
return 1
} else {
my <db> eval {update porg_member set accessmask=accessmask|:accessmask where groupid=:groupid and porgid=:memberid}
return 0
}
set dat [my <db> eval {porga,porgb,accessmask,linktypemask where porga=:groupid and porgb=:memberid}]
foreach {a b acc ltype} $dat {
my Group_Member_Expand $a $b $acc $ltype
}
}
###
# Hives are exclusive sets. A link cannot belong to more than one hive.
# But hives can cross through individual nodes.
# Example: Fred is the father of Marsha. Fred and Marsha are family.
# All people that Fred is related to are also related to Marsha.
# (What we call the various relationships that ensue is a complex mess,
# but we can at the very least set a 'family' bit.)
# So if we list John as a spouse of Marsha, John is now included in Fred's family circle.
# If John has a brother Roy, Roy is also now in Fred's family circle. And conversely,
# Roy is ALSO on Fred's family circle, as is Roy and John's parent, any other children
# they have, and so forth.
###
method Hive_Expand {porgid port linkid queen} {
my <db> eval {select porgid as oporgid,port as oport,linkid as olinkid,queen as oqueen from porg_hive} {
# Already part of the same queen, nothing to do
if {$oqueen == $queen} continue
# Attached to the same porg, with the same type of connection
# for now assume that we are going to expand the link
if {$porgid == $oporgid && $port eq $oport} {
my Hive_Combine $queen $oqueen
return 1
}
###
# Mor
}
return 0
}
method Hive_Combine {queena queenb} {
if {$queenb>$queena} {
my <db> eval {update porg_hive set queen=:queena where queen=:queenb}
} else {
my <db> eval {update porg_hive set queen=:queenb where queen=:queena}
}
}
###
# Left off here
# Need to revise our link walking rules
###
method Porg_Members_Expand {group porgid bitmap amask tmask resultvar} {
dict with bitmap {}
upvar 1 $resultvar result
#if {[dict exists $result $porgid]} return
set dat [my <db> eval {select porgb,accessmask,linktypemask from link where porga=:porgid and ((linktypemask & :memberbit) || (linktypemask & :gmemberbit));}]
foreach {user uaccess utype} $dat {
if {[dict exists $result $user]} {
dict with result $user {
set accessmask [expr {$accessmask | $uaccess & $amask}]
set linktypemask [expr {$accessmask | $utype & $tmask}]
}
} else {
dict set result $user [dict create accessmask [expr {$uaccess & $amask}] linktypemask $utype]
my Porg_Members_Expand $porgid $user $bitmap [expr {$uaccess & $amask}] $utype result
}
}
}
method porg_members {group} {
return [dict keys [my Porg_Members $group]]
}
method Porg_Members {group} {
set groupid [my porgid $group]
set stmt {select porgid,accessmask from porg_member where groupid=:groupid}
if {[my <db> exists $stmt]} {
return [my <db> eval $stmt]
}
set bitmap {}
dict set bitmap memberbit [my porgword_mask linktypemask member]
dict set bitmap gmemberbit [my porgword_mask linktypemask group inferior]
dict set bitmap groupbit [my porgword_mask linktypemask group]
dict set bitmap superbit [my porgword_mask linktypemask superior]
dict set bitmap subbit [my porgword_mask linktypemask inferior]
dict set bitmap anybit [my porgword_mask linktypemask superior inferior member group]
dict set bitmap adminbit [my porgword_mask privilege admin executive]
dict with bitmap {}
set result {}
set dat [my <db> eval {select porgb,accessmask,linktypemask from link where porga=:groupid and ((linktypemask & :memberbit) or (linktypemask & :gmemberbit)==:gmemberbit);}]
foreach {user accessmask linktypemask} $dat {
dict set result $user [dict create accessmask $accessmask linktypemask $linktypemask]
my Porg_Members_Expand $groupid $user $bitmap $accessmask $linktypemask result
}
set dat [my <db> eval {select porgb,accessmask,linktypemask from link where porgb=:groupid and ((linktypemask & :groupbit|:superbit)=:groupbit|:superbit);}]
foreach {user accessmask linktypemask} $dat {
if {$accessmask==0} continue
dict set result $user [dict create accessmask $accessmask linktypemask $linktypemask]
my Porg_Members_Expand $groupid $user $bitmap $accessmask $linktypemask result
}
###
# Cache the result
###
# Add administrative access hook
my <db> eval {insert into porg_member(porgid,groupid,accessmask,linktypemask) VALUES (-1,:groupid,-1,-1)}
foreach {userid info} $result {
dict with info {}
my <db> eval {insert into porg_member(porgid,groupid,accessmask,linktypemask) VALUES (:userid,:groupid,:accessmask,:linktypemask)}
}
return [my <db> eval $stmt]
}
method Porg_Admin_User {user} {
my variable admin_user_list
if {![info exists admin_user_list]} {
return 0
}
return [expr {$user in $admin_user_list}]
}
method admin_check {user} {
set userid [my porgid $user]
return [my Porg_Admin_User $user]
}
###
# Users of type wheel or part of a wheel group
# may elevate their privileges
###
method porg_wheel_enable {user} {
my variable admin_user_list
if {![info exists admin_user_list]} {
set admin_user_list {}
}
if {$user in $admin_user_list} {
return 0
}
set mask [my porgword_mask porgtypemask user wheel]
if {[my <db> exists {select porgid from porg where (porgtypemask & :mask)==:mask and porgid=:user}]} {
lappend admin_user_list $user
return 0
}
set mask [my porgword_mask porgtypemask group wheel]
set grouplist [my <db> eval {select porgid from porg where (porgtypemask & :mask)==:mask}]
foreach id $grouplist {
set memberinfo [my Porg_Members $id]
if {[dict exists $memberinfo $user]} {
lappend admin_user_list $user
return 0
}
}
error "User does not have wheel privileges"
}
method porg_wheel_disable {user} {
my variable admin_user_list
if {![info exists admin_user_list]} {
set admin_user_list {}
return
}
set oldlist $admin_user_list
set admin_user_list {}
foreach item $oldlist {
if {$item ne $user} { lappend admin_user_list $item }
}
}
method porg_rights {user group} {
set result 0
set groupid [my porgid $group]
set userid [my porgid $user]
if {[my Porg_Admin_User $user]} {
return -1
}
set stmt {select accessmask from porg_member where porgid=:userid and groupid=:groupid}
if {[my <db> exists $stmt]} {
set result [my <db> onecolumn $stmt]
return $result
}
set info [my Porg_Members $groupid]
if {[dict exists $info $userid]} {
set value [dict get $info $userid]
return $value
}
set memberbit [my porgword_mask linktypemask member]
###
# Build a mapping from this group to a group the user does belong to
###
set dat [my <db> eval {select porga,accessmask,linktypemask from link where porgb=:groupid and (linktypemask & :memberbit);}]
foreach {ogroup accessmask linktypemask} $dat {
set info [my Porg_Members $ogroup]
if {[dict exists $info $userid]} {
return [dict get $info $userid]
}
}
return 0
}
}