(module page mzscheme
(require "hwikireq.scm")
(require "plugins.scm")
(require "config.scm")
(require "template.scm")
(provide page
register-page
default-page
page-base
part-name
part-file
part-editor
)
(define (part-name part)
(car part))
(define (part-file part)
(cadr part))
(define (part-editor part)
(if (plugin-exists? (part-name part))
(plugin-editor (part-name part))
'html))
(def-class
(this (page-base))
(supers)
(private
(define _special #f)
(define _page-name #f)
)
(public
(define (special?) _special)
(define (special!) (set! _special #t))
(define (name)
_page-name)
(define (name! pne)
(set! _page-name pne))
(define (do-error message next-procedure)
(send/suspend (lambda (url)
(make-response/xhtml `(html
(head (link ((rel "stylesheet") (href ,(-> (-> this get-template) css)) (type "text/css")))
(title ,(_ "HWiki Error")))
(body
(div ((class "error"))
,message)
(form
((action ,url) (method "post"))
(input ((type "submit") (name "submit") (value ,(_ "ok"))))))))))
(next-procedure))
(define (create-header context _title _css)
(hlog 'page (-> context page-name) 'from (-> context from-where) 'title _title)
(let ((R
(append
`(head (link ((rel "stylesheet") (href ,_css) (type "text/css")))
(meta ((name "generator") (content ,(string-append "HWiki " HWIKI-VERSION " - wysiwyg wiki, based on the PLT Scheme webserver and using the TinyMCE component"))))
(meta ((name "copyright") (content "(c) Hans Oesterholt-Dijkema 2007")))
(meta ((http-equiv "Content-Type") (content "text/html;charset=UTF-8")))
(title ,_title))
(-> context extra-headers))))
R))
)
(constructor)
)
(def-class
(this (default-page context . the-page-name))
(supers (page-base))
(private
(define _template #f)
(define _title "")
(define _paths (cfile context))
(define (lock) #t)
(define (unlock) #t)
(define (load)
(let ((p (with-handlers ((exn:fail? (lambda (exn) (list "default" ""))))
(let ((fh (open-input-file (-> _paths filename 'page (-> supers name)))))
(let ((R (read fh)))
(close-input-port fh)
R)))))
(debug "default-page:load:" p)
(set! _template (template 'context context 'name (car p)))
(set! _title (cadr p))))
(define (save)
(lock)
(let ((fh (open-output-file (-> _paths filename 'page (-> supers name)) 'replace)))
(write (list (-> _template name) _title) fh)
(close-output-port fh))
(unlock))
)
(public
(define (get-template) _template)
(define (template! tmpl)
(set! _template (template 'context context 'name tmpl))
(save))
(define (plugin? part)
(plugin-exists? (part-name part)))
(define (mkdiv partname)
(-> context mkdiv partname))
(define (get-part-file part)
(if (eq? (part-file part) #f)
(string-append (-> this name) "." (part-name part))
(part-file part)))
(define (create-html)
(lambda (url)
(adjust-timeout! 30)
(make-response/xhtml
(let ((body (append `(body)
(map (lambda (part)
(if (plugin? part)
(let ((p (plugin-function (part-name part))))
(-> context file! (-> _paths filename 'document (get-part-file part)))
(-> context url! url)
(-> context current-part! part)
(make-comment (format "--><div class=\"~a\">~a</div><!--" (mkdiv (part-name part)) (p context))))
(make-comment (format "--><div class=\"~a\">~a</div><!--"
(part-name part)
(-> this contents part)))))
(-> _template parts))
(-> context process-parts url))))
`(html
,(-> supers create-header context _title (-> _template css))
,body)))))
(define (has-contents? part)
(file-exists? (-> _paths filename 'document (get-part-file part))))
(define (contents part)
(let ((name (get-part-file part)))
(letrec ((f (lambda (L)
(if (null? L)
(if (file-exists? (-> _paths filename 'document name))
(let ((fh (open-input-file (-> _paths filename 'document name))))
(let ((R (read-whole-string fh)))
(close-input-port fh)
R))
(if (eq? (part-editor part) 'html) "<p></p>" ""))
(let ((lang (car L)))
(if (file-exists? (-> _paths filename 'document (format "~a.~a" lang name)))
(let ((fh (open-input-file (-> _paths filename 'document (format "~a.~a" lang name)))))
(let ((R (read-whole-string fh)))
(close-input-port fh)
R))
(f (cdr L))))))))
(f (-> context accepted-languages)))))
(define (contents! part C)
(let ((nme (get-part-file part)))
(let ((fh (open-output-file (-> _paths filename 'document nme) 'replace)))
(display C fh)
(close-output-port fh))))
(define (title)
_title)
(define (title! t)
(set! _title t)
(save))
)
(constructor
(-> supers name! (if (null? the-page-name)
(-> context page-name)
(car the-page-name)))
(load)
)
)
(define PAGES (list))
(define (page context . pgnme)
(let ((page-name (if (null? pgnme) (-> context page-name) (car pgnme))))
(letrec ((f (lambda (P)
(debug "page" page-name " , " P)
(if (null? P)
default-page
(if (string-ci=? page-name (caar P))
(cadar P)
(f (cdr P)))))))
(let ((pageClass (f PAGES)))
(let ((P (if (eq? pageClass default-page)
(pageClass context page-name)
(pageClass context))))
P)))))
(define (register-page name class)
(set! PAGES (cons (list name class) PAGES)))
)