(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)
            (let ((_title (-> this title))
                  (_css   (-> this 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")))
                             (meta  ((http-equiv "expires") (content "0")))
                             (title ,_title))
                      (-> context extra-headers))))
                R)))
             
          (define (not-autorized context message)
            (let ((form (lambda (url)
                          (adjust-timeout! (form-timeout))
                          (-> context make-response/xhtml
                              `(html
                                ,(-> this create-header context)
                                (body
                                 (div ((class "msgdlg"))
                                      (h1 ,(_ "HWiki - Not Autorized"))
                                      (form ((action ,url) (method "post"))
                                            (table 
                                             (tr (td ((collspan "2"))
                                                     ,message))
                                             (tr (td)
                                                 (td (input ((type "submit") (name "action") (value ,(_ "OK")))))))
                                             ))))
                              ))))
              (send/suspend form)
              (-> context to-from-where)))
          
          (define (message context header message)
            (let ((form (lambda (url)
                          (adjust-timeout! (form-timeout))
                          (-> context make-response/xhtml
                              `(html
                                ,(-> this create-header context)
                                (body
                                 (div ((class "msgdlg"))
                                      (h1 ,header)
                                      (form ((action ,url) (method "post"))
                                            (table 
                                             (tr (td ((collspan "2"))
                                                     ,message))
                                             (tr (td)
                                                 (td (input ((type "submit") (name "action") (value ,(_ "OK")))))))
                                             ))))
                              ))))
              (send/suspend form)
              (-> context to-from-where)))
            
          )
         (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 (css)          
            (-> _template css))

          (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)
              (-> context add-extra-header `(meta ((http-equiv "expires") (content "0"))))
              (-> context 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)
                      ,body)))))

          (define (has-contents? part)
            (file-exists? (-> _paths filename 'document (get-part-file part))))
          
          (define (contents part . no-langs)
            (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 (if (and (not (-> context logged-in?)) (null? no-langs))
                       (-> 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)))

        )