(module context mzscheme
        (require "hwikireq.scm")
        (require "config.scm")
        (provide context
                 get-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)
                            #f
                            (if (eq? (caar H) 'cookie)
                                (let ((C (cdar H)))
                                  (debug "cookie: " C)
                                  (if (string-ci=? (substr C 0 15) "hwikisessionid=")
                                      (substr C 15)
                                      (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 session-id! S)
                (-> C process-request request)
                C))))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;; Context class
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (def-class
         (this (context . args))
         (supers)
         (private
          (define _request #f)

          (define _extra-parts (list))

          (define _props           (make-hash-table))
          (define _from-ip         "0.0.0.0")
          (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 _cookies              (make-hash-table))
          (define _cookies-from-browser (make-hash-table))
          (define _headers              (make-hash-table))
          
          )
         (public
          (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 (session-id! S)         (set! _session-id S))
          (define (session-id)            _session-id)
          
          (define (role-admin?) 
            (and logged-in? (eq? role 'admin)))
          
          (define (role-editor?)
            (and logged-in? (or (eq? role 'editor) (eq? role 'admin))))
          
          (define (role-reader?)
            (eq? role 'reader))
          
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;;; cookies
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          
          (define (cookie! key value . expiry-seconds)
            (if (not (symbol? key))   (error "context:cookie!:key must be a symbol"))
            (if (not (string? value)) (error "context:cookie!:value must be a string"))
            (hash-table-put! _cookies key (lambda ()
                                            (if (not (null? expiry-seconds))
                                                (format "~a=~a; path=~a; expires=~a" 
                                                        key value
                                                        "/servlets"
                                                        (let* ((t  (current-time))
                                                               (t1 (make-time time-duration 0 (car expiry-seconds)))
                                                               (tt (add-duration t t1)))
                                                          (let ((d (time-utc->date tt)))
                                                            (date->string d "~a, ~d ~b ~Y ~T UTC"))))
                                                (format "~a=~a; path=~a"
                                                        key value
                                                        "/servlets"
                                                        )))))
;                                            (cookie:add-domain
;                                             (cookie:add-path
;                                              (cookie:add-max-age
;                                               (set-cookie (symbol->string key) value)
;                                               (if (null? expiry-seconds)
;                                                   (* 24 3600)
;                                                   (car expiry-seconds)))
;                                              "/servlets"))))
;                                             (host)))))
          
          (define (cookie key)
            (let ((c (hash-table-get _cookies key (lambda () #f))))
              (if (eq? c #f)
                  (hash-table-get _cookies-from-browser key)
                  (c))))
          
          (define (cookie-response val)
            val)
          
          (define (get-cookies)
            (let ((R 
                   (hash-table-map _cookies
                                   (lambda (key val)
                                     `(Set-Cookie . ,(cookie-response (val)) )))))
              (debug (format "COOKIES: ~s" R))
              R))
          
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

          (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)
            _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)
                                                       (list)
                                                       (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)
                                                 (list)
                                                 (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))
                 _extra-parts))
          
          (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)
                #t
                (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)
                                    "index"
                                    (let ((p (cadr page)))
                                      (if (string=? (string-trim-both p) "")
                                          "index"
                                          (string-trim-both p)))))
                (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") 
                                           (begin
                                             (debug "FROM-WHERE=" (caddr M))
                                             (set! from-where (caddr M))))
                                          (else (request-value! (cadr M) (caddr M)))))))
                            values)))
            (debug "page: " page-name ", context: " _context)
            (set! _request request))
          
          (define (make-response/xhtml html)
            (make-response/full 200 "okay"
                                (current-seconds)
                                #"text/html"
                                (get-cookies)
                                (list xhtml1-transitional
                                      (xexpr->string html))))
          
          (define (make-redirect page)
            (let ((url (string-append WIKI-PATH "/" page ".html")))
              (make-response/full 302 "redirection"
                                  (current-seconds)
                                  #"text/html"
                                  (append (get-cookies)
                                          `((Location . ,url)))
                                  (list xhtml1-transitional
                                        (xexpr->string
                                         `(html (head (meta ((http-equiv "refresh") (url ,url))))
                                                (body (p "redirecting to " (a ((href ,url)) ,url)))))))))
          
          (define (logged-in!)
            (lambda (url)
              (let ((S (new-session-id)))
                (set! _session-id S)
                (store-context S this)
                (cookie! 'hwikisessionid S)
                (make-redirect "index"))))
                
;                (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"
;                              (current-seconds)
;                              #"text/html"
;                              `((Set-Cookie . ,(print-cookie c))
;                                (Location . ,(string-append WIKI-PATH "/index.html")))
;                              (list "<html><head></head><body><p>logged in</p></body></html>"))))
;                      R))))))

          (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 "")))
                (make-redirect from-where))))
;                (redirect-to (string-append WIKI-PATH "/" from-where ".html") 'temporarily))))
;

          (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))
          
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; Extra headers for in html
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          
          (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))

          )
         (constructor
          )
         )



        ); end module