;; Copyright (c) <2009> David Krentzlin <david@lisp-unleashed.de>
;; 
;;   Permission is hereby granted, free of charge, to any person
;;   obtaining a copy of this software and associated documentation
;;   files (the "Software"), to deal in the Software without
;;   restriction, including without limitation the rights to use,
;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
;;   copies of the Software, and to permit persons to whom the
;;   Software is furnished to do so, subject to the following
;;   conditions:
;; 
;;   The above copyright notice and this permission notice shall be
;;   included in all copies or substantial portions of the Software.
;; 
;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;   OTHER DEALINGS IN THE SOFTWARE.
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module uri-dispatch
  (dispatch-error dispatch-environment invoke-handler
   whitelist default-dispatch-target dispatch-uri)
  (import scheme chicken)
  (require-library uri-common environments srfi-13 srfi-1 data-structures)
  (import (only uri-common uri-reference? uri-path)
          (only srfi-13 string-append)
          (only srfi-1 find)
          (only data-structures alist-ref conc constantly)
          (only environments environment-ref environment-has-binding?))

  (define dispatch-error (make-parameter (constantly #f)))
  (define whitelist (make-parameter #f))
  (define dispatch-environment (make-parameter (interaction-environment)))
  (define default-dispatch-target (make-parameter #f))

  (define (default-invoker procedure  arguments)
    (condition-case
     (apply procedure arguments)
     (exn () (dispatch-error exn))))

  (define invoke-handler (make-parameter default-invoker))

  (define (dispatch-uri uri)
    (unless (uri-reference? uri)
      (error "Supplied argument must be an uri"))
    (let ((path (cdr (uri-path uri))))
      (cond
       ((null? path)
        (apply (or (default-dispatch-target)
                   (dispatch-error)) '()))
       ((null? (cdr path))
        (if (equal? (car path) "")
            (apply (or (default-dispatch-target) (dispatch-error)) '())
            (let ((handler (handler-ref (string->symbol (car path)))))
              (if handler
                  ((invoke-handler) handler (cdr path))
                  (apply (dispatch-error) path)))))
       (else
        (let ((mod/proc (handler-ref (string->symbol (cadr path)) (string->symbol (car path)))))
          (if mod/proc
              (apply mod/proc (cddr path))
              (let ((handler (handler-ref (string->symbol (car path)))))
                (if handler
                    ((invoke-handler) handler (cdr path))
                    (apply (dispatch-error) path)))))))))

  (define (handler-ref symbol #!optional (mod #f))
    (and-let* ((name (if mod (string->symbol (conc mod "#" symbol)) symbol))
               ((environment-has-binding? (or (dispatch-environment)
                                              (interaction-environment)) name))
               (binding (environment-ref (or (dispatch-environment)
                                             (interaction-environment)) name))
               ((procedure? binding))
               ((whitelisted? symbol mod)))
      binding))

  (define (whitelisted? symbol mod)
    (or (not (whitelist))
        (if (not mod)
            (memq symbol (whitelist))
            (let ((module.symbols (find (lambda (p)
                                          (and (pair? p)
                                               (eq? mod (car p))))
                                        (whitelist))))
              (and module.symbols
                   (or (eq? (cdr module.symbols) '*)
                       (memq symbol (cdr module.symbols))))))))

)