Index: openacs-4/packages/xotcl-core/tcl/ical-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/ical-procs.tcl,v
diff -u -r1.2 -r1.3
--- openacs-4/packages/xotcl-core/tcl/ical-procs.tcl	3 Dec 2007 11:21:15 -0000	1.2
+++ openacs-4/packages/xotcl-core/tcl/ical-procs.tcl	16 Jun 2008 11:58:45 -0000	1.3
@@ -74,4 +74,169 @@
     return $text
   }
   
-}
\ No newline at end of file
+}
+
+namespace eval ::xo {
+  Class create dav -parameter {
+    {url /webdav}
+    {package}
+  }
+
+  dav ad_instproc unknown {method args} {
+    Return dav specific connection info similar to ad_conn
+  } {
+    my log "--dav unknown called with '$method' <$args>"
+    switch [llength $args] {
+      0 {if {[my exists $method]} {return [my set method]}
+        return [ad_conn $method]
+      }
+      1 {my set method $args}
+      default {my log "--dav ignoring <$method> <$args>"}
+    }
+  }
+
+  dav ad_instproc set_user_id {} {
+    Set user_id based on authentication header
+  } {
+    set ah [ns_set get [ns_conn headers] Authorization]
+    if {$ah ne ""} {
+      # should be something like "Basic 29234k3j49a"
+      my debug "auth_check authentication info $ah"
+      # get the second bit, the base64 encoded bit
+      set up [lindex [split $ah " "] 1]
+      # after decoding, it should be user:password; get the username
+      set user [lindex [split [ns_uudecode $up] ":"] 0]
+      set password [lindex [split [ns_uudecode $up] ":"] 1]
+      array set auth [auth::authenticate \
+                          -username $user \
+                          -authority_id [::auth::get_register_authority] \
+                          -password $password]
+      my debug "auth $user $password returned [array get auth]"
+      if {$auth(auth_status) ne "ok"} {
+        array set auth [auth::authenticate \
+                            -email $user \
+                            -password $password]
+        if {$auth(auth_status) ne "ok"} {
+          my debug "auth status $auth(auth_status)"
+          ns_returnunauthorized
+          my set user_id 0
+          return 0
+        }
+      }
+      my debug "auth_check user_id='$auth(user_id)'"
+      ad_conn -set user_id $auth(user_id)
+      
+    } else {
+      # no authenticate header, anonymous visitor
+      ad_conn -set user_id 0
+      ad_conn -set untrusted_user_id 0
+    }
+    my set user_id [ad_conn user_id]
+  }
+
+  dav ad_instproc initialize {} {
+    Setup connection object and authenticate user
+  } {
+    my instvar uri method urlv destination
+    ad_conn -reset
+    set uri [ns_urldecode [ns_conn url]]
+    set dav_url_regexp "^[my url]"
+    regsub $dav_url_regexp $uri {} uri
+    if {$uri eq ""} {
+      set uri "/"
+    }
+    my set_user_id
+
+    set method [string toupper [ns_conn method]]
+    #my log "--dav conn_setup: uri '$uri' method $method"
+    set urlv [split [string trimright $uri "/"] "/"]
+    set destination [ns_urldecode [ns_set iget [ns_conn headers] Destination]]
+    regsub {https?://[^/]+/} $destination {/} dest
+    regsub $dav_url_regexp $dest {} destination
+    #my log "--dav conn_setup: destination = $destination"
+  }
+
+  dav ad_instproc preauth { args } {
+    Check if user_id has permission to perform the WebDAV method on
+    the URI
+  } {
+    #my log "--dav preauth args=<$args>"
+    my instvar user_id 
+    
+    # Restrict to SSL if required
+    if { [security::RestrictLoginToSSLP]  && ![security::secure_conn_p] } {
+      ns_returnunauthorized
+      return filter_return
+    }
+  
+    # set common data for all kind of requests 
+    my initialize
+
+    # for now, require for every user authentification
+    if {$user_id == 0} {
+      ns_returnunauthorized
+      return filter_return
+    }
+    
+    #my log "--dav preauth filter_ok"
+    return filter_ok    
+  }
+
+  dav ad_instproc register { } {
+    Register the the aolserver filter and traces.
+    This method is typically called via *-init.tcl.
+  } {
+    set filter_url [my url]*
+    set url [my url]/*
+    foreach method {
+      GET HEAD PUT MKCOL COPY MOVE PROPFIND PROPPATCH
+      DELETE LOCK UNLOCK
+    } {
+      ns_register_filter preauth $method $filter_url  [self]
+      ns_register_proc $method $url [self] handle_request
+      #my log "--dav ns_register_filter preauth $method $filter_url  [self]"
+      #my log "--dav ns_register_proc $method $url [self] handle_request"
+    }
+  }
+
+  dav instproc GET {} {
+    my instvar uri
+    my log "--dav handle_request GET method"
+    #set with_recurrences [ns_queryget with_recurrences 1]
+    # ...
+    ns_return 200 text/plain GET-$uri
+  }
+  dav instproc PUT {} {
+    my log "--dav handle_request PUT method [ns_conn content]"
+    #set calendar_id_list [ns_queryget calendar_id_list 0]
+    #if {[llength $write_calendar_ids] == 0} {
+    #ns_return 403 text/plain "no permissions to write to calendar"
+    #} else {
+    ns_return 201 text/plain "0 items processed"
+    #}
+  }
+  dav instproc PROPFIND {} {
+    my log "--dav PROPFIND [ns_conn content]"
+    ns_return 204 text/xml {<?xml version="1.0" encoding="utf-8" ?>}
+  }
+
+  dav ad_instproc handle_request { args } {
+    Process the incoming web-dav request. This method
+    could be overloaded by the application and
+    dispatches the HTTP requests.
+  } {
+    my instvar uri method user_id
+  
+    #my log "--dav handle_request method=$method uri=$uri\
+    #	userid=$user_id -ns_conn query '[ns_conn query]'"
+    if {[my exists package]} {
+      [my package] initialize -url $uri
+      #my log "--dav [my package] initialize -url $uri"
+    }
+    if {[my procsearch $method] ne ""} {
+      my $method
+    } else {
+      ns_return 404 text/plain "not implemented"
+    }
+  }
+}