(module context mzscheme
        (require "hwikireq.scm")
        (require "config.scm")
        (provide context

        ;; Sessions, context information

        (define LAST-SESSION-ID 0)
        (define (new-session-id)
          (set! LAST-SESSION-ID (+ LAST-SESSION-ID 1))
          (format "session_~a_~a" (random 100000000) LAST-SESSION-ID))

        (define SESSION-HASH (make-hash-table 'equal))
        (define (store-context session-id context)
          (hash-table-put! SESSION-HASH session-id context))

        (define (clear-context session-id)
          (hash-table-remove! SESSION-HASH session-id))

        (define (get-context request)
          (letrec ((f (lambda (H)
                        (if (null? H)
                            (if (eq? (caar H) 'cookie)
                                (let ((C (cdar H)))
                                  (debug "cookie: " C)
                                  (if (string-ci=? (substr C 0 17) "hwiki_session_id=")
                                      (substr C 17)
                                      (f (cdr H))))
                                (f (cdr H)))))))
            (let* ((HEADERS (request-headers request))
                   (S (f HEADERS)))
              (debug "Session:" S)
              (debug "Headers:" HEADERS)
              (let ((C (hash-table-get SESSION-HASH S (lambda () (context)))))
                (-> C process-request request)

        ;; Context class

         (this (context . args))
          (define _request #f)

          (define _extra-parts (list))

          (define _props           (make-hash-table))
          (define _from-ip         "")
          (define _languages       '())
          (define _user            "")
          (define _file            #f)

          (define _session-id      #f)

          (define _context         "")

          (define _url             #f)
          (define _account         #f)
          (define _current-part    #f)
          (define _host            "")
          (define _request-vals    (make-hash-table))
          (define _extra-headers   '())
          (define role             'reader)
          (define current-template #f)
          (define page-name        "")
          (define from-where       "")
          (define logged-in?       #f)

          (define (file! f)               (set! _file f))
          (define (file)                  _file)
          (define (url! u)                (set! _url u))
          (define (url)                   _url)
          (define (user! u)               (set! _user u))
          (define (user)                  _user)
          (define (accepted-languages! l) (set! _languages l))
          (define (accepted-languages)     _languages)
          (define (current-part! p)       (set! _current-part p))
          (define (current-part)          _current-part)
          (define (host)                  _host)
          (define (host! h)               (set! _host h))
          (define (request-value key)     (hash-table-get _request-vals key (lambda () #f)))

          (define (request-value! key v)  
            (debug "request-value!: " key " = " v)
            (hash-table-put! _request-vals (string->symbol (format "~a" key)) v))
          (define (request-values)
            (hash-table-map _request-vals (lambda (key val) (cons key val))))

          (define (from-ip)

          (define (from-where! n) (set! from-where n))

          (define (register-part type code)
            (set! _extra-parts (cons (list type code)
                                     (letrec ((f (lambda (parts)
                                                   (if (null? parts)
                                                       (if (eq? (caar parts) type)
                                                           (f (cdr parts))
                                                           (cons (car parts) (f (cdr parts))))))))
                                       (f _extra-parts)))))

          (define (remove-part type)
            (set! _extra-parts (letrec ((f (lambda (parts)
                                             (if (null? parts)
                                                 (if (eq? (caar parts) type)
                                                     (f (cdr parts))
                                                     (cons (car parts) (f (cdr parts))))))))
                                 (f _extra-parts))))

          (define (process-parts url)
            (map (lambda (part)
                   ((cadr part) this url))
          (define re-lang (pregexp "[;][^,]+"))
          (define (mklang str)
            (splitstr (pregexp-replace* re-lang str "") #\,))

          (define (mkdiv partname)
            (pregexp-replace* "[:-]" partname "_"))
          (define (process-headers headers)
            (if (null? headers)
                (let ((H (car headers)))
                  (cond ((eq? (car H) 'x-forwarded-for) (set! _from-ip (cdr H)))
                        ((eq? (car H) 'accept-language) (set! _languages (mklang (cdr H))))
                        ((eq? (car H) 'host)            (set! _host (cdr H)))
                  (process-headers (cdr headers)))))

          (define re-key (pregexp "([^=]+)[=](.*)"))
          (define (process-request request)
            (set! _request-vals (make-hash-table))
            (process-headers (request-headers request))
            (debug "url:" (url->string (request-uri request)))
            (let ((url (url->string (request-uri request))))
              (let ((page (regexp-match "[/]([^.]+)([.]html)*([?].+)*$" url)))
                (set! page-name (if (eq? page #f)
                                    (cadr page)))
                (set! _context  (if (eq? page #f) "" (if (eq? (cadddr page) #f) "" (cadddr page))))))
            (if (not (string=? _context ""))
                (let ((values (splitstr _context '(#\? #\& #\;))))
                  (for-each (lambda (val)
                              (let ((M (regexp-match re-key val)))
                                (if (not (eq? M #f))
                                    (cond ((string-ci=? (cadr M) "context") (set! _context (caddr M)))
                                          ((string-ci=? (cadr M) "from-where") 
                                             (debug "FROM-WHERE=" (caddr M))
                                             (set! from-where (caddr M))))
                                          (else (request-value! (cadr M) (caddr M)))))))
            (debug "page: " page-name ", context: " _context)
            (set! _request request))

          (define (logged-in!)
            (lambda (url)
              (let ((S (new-session-id)))
                (set! _session-id S)
                (store-context S this)
                (let ((c (cookie:add-path (set-cookie "hwiki_session_id" S) SERVLET-PATH)))
                  (let ((U (regexp-replace "[/]([^.]+)([.]html)*$" url "")))
                    (let ((R (make-response/full
                              300 "logged-in"
                              `((Set-Cookie . ,(print-cookie c))
                                (Location . ,(string-append WIKI-PATH "/index.html")))
                              (list "<html>"))))

          (define (logout)
            (clear-context _session-id))

          (define (to-from-where)
            (lambda (url)
              (adjust-timeout! (expire-shortly-timeout))    ;;; to-from-where is always used in to end a form
                                                            ;;; Expire the form shortly.
              (if (string=? from-where "") 
                  (set! from-where "index"))
              (let ((U (regexp-replace "[/]([^.]+)([.]html)*$" url "")))
                (redirect-to (string-append WIKI-PATH "/" from-where ".html")))))

          (define (store-file contents name)
            (let ((_paths (cfile this)))
              (let ((fh (open-output-file (string-append (-> _paths document-root) "/" name) 'replace)))
                (write-bytes contents fh)
                (close-output-port fh))))

          (define (prop! plugin key value)
            (let ((P (hash-table-get _props plugin (lambda () (make-hash-table)))))
              (hash-table-put! P key value)
              (hash-table-put! _props plugin P)))

          (define (prop plugin key . default)
            (let ((P (hash-table-get _props plugin (lambda () (make-hash-table)))))
              (hash-table-get P key (lambda () (if (null? default)
                                                   (error "context -> prop: cannot get value")
                                                   (car default))))))

          (define (context) _context)
          (define (context! c) (set! _context c))
          (define (page-name! p) (set! page-name p))
          (define (reset-extra-headers!)
            (set! _extra-headers '()))
          (define (add-extra-header xexpr)
            (set! _extra-headers (cons xexpr _extra-headers)))
          (define (extra-headers)
            (reverse _extra-headers))


        ); end module