(module yppdb-util mzscheme
  (require (lib "contract.ss")
           (lib "servlet.ss" "web-server")
           (lib "servlet-sig.ss" "web-server")
           (lib "url.ss" "net")
           (lib "etc.ss")
           (lib "list.ss"))
  (provide (all-defined))
  
  (define/contract cdr?
    (list? . -> . list?)
    (lambda (l)
      (if (null? l)
          (list)
          (cdr l))))
  
  (define/contract list/uniqued
    ((listof any/c) . -> . (listof any/c))
    (lambda (l)
      (foldl
       (lambda (c b)
         (if (member c b)
             b
             (append b (list c))))
       `()
       l)))
    
  (define/contract write/string
    (any/c . -> . string?)
    (lambda (a)
      (let ([p (open-output-string)])
        (write a p)
        (get-output-string p))))
  (define/contract read/string
    (string? . -> . any/c)
    (lambda (s)
      (read (open-input-string s))))
  
  (define (base-url request)
    (let* ([url (url->string (request-uri request))]
           [regex (regexp-match "^(.*?\\.ss)(.*?)(\\?.*)?$"
                                (regexp-replace ";id[0-9]+\\*[0-9]+" url ""))])
      (if regex
          (cdr regex)
          url)))
  
  (define-syntax with-binding
    (syntax-rules ()
      [(_ bindings (single-name ...) body ...)
       (with-bindings bindings
                      ()
                      (single-name ...)
                      ()
                      body ...)]))  
  (define-syntax with-bindings
    (syntax-rules ()
      [(_ bindings (bool-name ...) (single-name ...) (multiple-name ...) body ...)
       (with-bindings/defaults bindings
                               (bool-name ...)
                               ((single-name #f) ...)
                               ((multiple-name (list)) ...)
                               body ...)]))
  (define-syntax with-bindings/defaults
    (syntax-rules ()
      [(_ bindings (bool-name ...) ((single-name single-default) ...) ((multiple-name multiple-default) ...) body ...)
       (let ([bool-name (exists-binding? 'bool-name bindings)]
             ...
             [single-name (if (exists-binding? 'single-name bindings)
                              (extract-binding/single 'single-name bindings)
                              single-default)]
             ...
             [multiple-name (if (exists-binding? 'multiple-name bindings)
                                (extract-bindings 'multiple-name bindings)
                                multiple-default)]
             ...)
         body
         ...)])))