(module context mzscheme
(require "hwikireq.scm")
(require "config.scm")
(provide context
get-context
)
(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 process-request request)
C))))
(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 (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 ()
(cookie:add-path
(cookie:add-max-age
(set-cookie (symbol->string key) value)
(if (null? expiry-seconds)
(* 24 3600)
(car expiry-seconds)))
"/servlets"))))
(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 (get-cookies)
(let ((R
(hash-table-map _cookies
(lambda (key val)
`(Set-Cookie . ,(print-cookie (val)))))))
(debug "COOKIES: " 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"
(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")
(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"))))
(define (logout)
(clear-context _session-id))
(define (to-from-where)
(lambda (url)
(adjust-timeout! (expire-shortly-timeout)) (if (string=? from-where "")
(set! from-where "index"))
(let ((U (regexp-replace "[/]([^.]+)([.]html)*$" url "")))
(make-redirect from-where))))
(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))
)
(constructor
)
)
)
![[logo]](/logo.png){kind=logo}