# $Id: s.PlaceAccessControl.xotcl 1.7 01/03/23 21:55:32+01:00 neumann@somewhere.wu-wien.ac.at $
package provide xotcl::mos::placeAccessControl 0.8

package require xotcl::comm::httpd
package require xotcl::comm::httpPlace

#
# Simple Object Pwd Protection with BasicAccessControl
#
#Usage example:
#ConferenceOrgPlace confPlace -port $placeport -root [pwd] \
#  -mixin PlaceAccessControl
#
#confPlace protect conference.html [confData set password]
#
#confPlace setPasswd conference.html xxx

Class ObjectAccessControl -superclass BasicAccessControl

ObjectAccessControl instproc protectedResource {fn method varAuthMethod varRealm} {
  # check whether access to $fn via $method is protected
  upvar $varAuthMethod authMethod $varRealm realm
  [self] instvar root
  # we check only the current directory, not the parent directories
  set call [url decodeItem $fn]
  regsub "^$root" $call "" call
  set call [string trimleft $call /]
  set call [string trimleft $call :]
  regexp {^([^ ]*)} $call _ call
  set call "$root/$call"

  foreach i [list $call $call:$method] {
    #puts stderr "check <$i>"
    if {[info exists [self]::protected($i)]} {
      set realm [set [self]::protected($i)]
      set authMethod Basic
      return 1
    }
  }
  return 0
}

Class PlaceAccessControl
PlaceAccessControl instproc init args {
  next
  [[self] httpd] mixinappend ObjectAccessControl
}

PlaceAccessControl instproc protect {objName id pwd} {
  set objName [string trimleft $objName :]
  [[self] httpd] protectDir $objName $objName {}
  if {$pwd != ""} {
    [self] setPassword $objName $id $pwd
  } 
}

PlaceAccessControl instproc credentialsNotOk {credentials authMethod realm} {
  parray [self]::passwd
  next
}

PlaceAccessControl instproc setPassword {obj id pwd} {
  set realm $obj
  set httpd [[self] httpd]
  if {[info exists ${httpd}::passwd($realm:$id)]} {
    $httpd unset passwd($realm:$id)
    $httpd set passwd($realm:$id) $pwd
  } else {
    $httpd addRealmEntry $realm "$id $pwd"
  }
  #$httpd set passwd($realm:admin) nimda
}
PlaceAccessControl instproc removeID {obj id} {
  set realm $obj
  set httpd [[self] httpd]
  if {[info exists ${httpd}::passwd($realm:$id)]} {
    unset ${httpd}::passwd($realm:$id)
  }
}

