plugin-blog.scm
(module plugin-blog mzscheme
        (require "hwikiplugin.scm")
        (provide register-plugin-blog
                 )

        (define context-new context)
        
        (define CREATED #f)

        (define (create-db)
          (if CREATED
              #t
              (let ((sqli (sqli-provider)))
                (if (eq? sqli #f)
                    #f
                    (begin
                      (sqli-query sqli (string-append
                                        "CREATE TABLE blog "
                                        "(context varchar,page varchar,dt timestamp,title varchar,html varchar,blogcount integer,"
                                        "PRIMARY KEY (context,page,blogcount)"
                                        ")"
                                        ))
                      (sqli-query sqli "CREATE TABLE blogcounters (context varchar,page varchar,blogcount integer, primary key (context,page))")
                      (sqli-query sqli "CREATE INDEX blog_idx0 ON blog(context,page,yearmonth,blogcount)")
                      (sqli-query sqli "CREATE INDEX blog_idx1 ON blog(context,page,blogcount)")
                      (sqli-closer sqli)
                      (set! CREATED #t)
                      #t)))))

        (define (edit-current context)
          (let ((sqli (sqli-provider))
                (_template  (template 'context context 'name "admin"))
                (CON  (-> context context))
                (PN   (-> context prop 'blog 'page))
                (BC   (-> context prop 'blog 'count)))
            (sqli-query sqli "SELECT title,dt,html FROM blog WHERE context=$1 AND page=$2 AND blogcount=$3" CON PN BC)
            (let ((row (sqli-fetchrow sqli)))
              (if (eq? row #f)
                  (begin
                    (sqli-closer sqli)
                    #f)
                  (let ((form (lambda (url)
                                (adjust-timeout! (edit-timeout))
                                (let* ((title      (car row))
                                       (dt         (sqli-convert sqli (cadr row) 'date))
                                       (contents   (caddr row))
                                       (page       (page context (-> context from-where)))
                                       (T           (-> page get-template))
                                       (CSS         (-> T css))
                                       )

                                  (make-response/xhtml
                                   `(html
                                     (head (link ((rel "stylesheet") (href ,(-> _template css)) (type "text/css")))
                                           (title ,(_ "HWiki Edit Blog Entry")))
                                     (body
                                      (form ((enctype "multipart/form-data") (action ,url) (method "post") (name "blogedit"))
                                            ,(_ "Title: ") 
                                            (input ((type "text") (name "title") (size "100") (value ,title)))
                                            (br)(br)
                                            (input ((type "hidden") (name "action") (value "cancel")))
                                            (textarea ((class "editarea") (name "text") ) ,(if (eq? contents #f) "<p></p>" contents) )
                                            (script ((language "javascript") (type "text/javascript") (src "/tinymce/jscripts/tiny_mce/tiny_mce.js")) "")
                                            (script ((language "javascript") (type "text/javascript"))
                                                    ,(string-append "function tinymce_save() { document." "blogedit" "." "action" ".value=\"commit\";document." "blogedit" ".submit(); }"
                                                                    "function tinymce_cancel() { document." "blogedit" "." "action" ".value=\"cancel\";document." "blogedit" ".submit(); }"
                                                                    "function setEditorCSS() { tinyMCE.getInstanceById('mce_editor_0').getWin().document.body.className='" "blog" "'; }"
                                                                    "tinyMCE.init({ theme : \"advanced\", "
                                                                    "mode : \"textareas\", "
                                                                    "plugins : \"print,save,table,cancel,media,wikilink\", " ;,fullscreen
                                                                    "save_enablewhendirty : false, "
                                                                    "save_onsavecallback : \"tinymce_save\", "
                                                                    "cancel_oncancelcallback : \"tinymce_cancel\", "
                                                                    "theme_advanced_toolbar_location : \"top\", "
                                                                    "theme_advanced_toolbar_align    : \"left\", "
                                                                    "theme_advanced_buttons2 : \"separator,formatselect,fontselect,fontsizeselect,removeformat,separator,bold,italic,underline,istriketrhough,sub,sup,separator,justifyleft,justifycenter,justifyright,justifyfull,separator,bullist,numlist,indent,outdent\", "
                                                                    "theme_advanced_buttons1 : \"separator,save,cancel,separator,print,fullscreen,separator,cut,copy,paste,separator,undo,redo,separator,wikilink,link,unlink,anchor,image,media,hr,separator,code,separator,tablecontrols\", "
                                                                    "theme_advanced_buttons3 : \"\", "
                                                                    "theme_advanced_statusbar_location : \"bottom\", "
                                                                    "fullscreen_new_window : false, "
                                                                    "fullscreen_settings : { theme_advanced_path_location : \"top\" }, "
                                                                    "inline_styles : true, "
                                                                    "oninit : \"setEditorCSS\", "
                                                                    "apply_source_formatting : true, "
                                                                    "relative_urls : true, "
                                                                    "extended_valid_elements : \"script[charset|defer|language|src|type]\", "
                                                                    "content_css : \"" CSS "\" "
                                                                    "});"))
                                            )
                                      )
                                     ))
                                  ))))
                    (let ((bindings (request-bindings (send/suspend form))))
                      (let ((action (extract-binding/single 'action bindings)))
                        (if (string-ci=? action "commit")
                            (sqli-query sqli
                                        "update blog set title=$1,html=$2 WHERE context=$3 and page=$4 and blogcount=$5"
                                        (extract-binding/single 'title bindings)
                                        (extract-binding/single 'text  bindings)
                                        CON
                                        PN
                                        (-> context prop 'blog 'count)))
                        (sqli-closer sqli)
                        #t)))))))

        (define (add-entry context)
          (-> context to-from-where))

        (define (remove-entry context)
          (-> context to-from-where))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;; Edit a blog
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (def-class 
         (this (blog-edit context))
         (supers (page-base))
         (private
          (define _template (template 'context context 'name "admin"))
          )
         (public
          (define (get-template) _template)
          
          (define (create-html)
            (-> context prop! 'blog 'count (string->number (-> context request-value 'blogcount)))
            (-> context prop! 'blog 'page  (-> context request-value 'page))
            (let ((contents (edit-current context)))
              (-> context to-from-where)))
          )
         (constructor
          (-> supers special!)
          ))
        
        (def-class 
         (this (blog-add context))
         (supers (page-base))
         (private
          (define _template (template 'context context 'name "admin"))
          )
         (public
          (define (get-template) _template)
          
          (define (create-html)
            (-> context prop! 'blog 'count (increase-counter context))
            (-> context prop! 'blog 'page  (-> context request-value 'page))
            
            (let ((sqli  (sqli-provider))
                  (count (-> context prop 'blog 'count))
                  (dt    (current-date))
                  (title "<empty>")
                  (CON   (-> context context))
                  (PN    (-> context prop 'blog 'page))
                  (html  "<p>empty blog entry</p>"))
              (sqli-query sqli "insert into blog(context,page,blogcount,dt,title,html) values($1,$2,$3,$4,$5,$6)"
                          CON PN count dt title html)
              (sqli-closer sqli))
            
            (let ((contents (edit-current context)))
              (-> context to-from-where)))
          )
         (constructor
          (-> supers special!)
          ))
        
        
        
        (def-class
         (this (blog-rss context))
         (supers)
         (private)
         (public
          
;          (define (get-template)
;            (template 'context context 'name "admin"))
          
          (define (special?)
            #t)
          
          (define (rss)
            (newline)(newline)
            (display context)(newline)(newline)
            (let* ((C1    (let ((R (context-new)))
                            (-> R context! (-> context context))
                            (-> R page-name! (-> context request-value 'page))
                            R))
                   (P     (page C1))
                   (paths (cfile context))
                   (CON   (-> C1 context))
                   (PN    (-> C1 page-name)))
              (display P)(newline)
              (let ((sqli (sqli-provider)))
                (sqli-query sqli "SELECT max(blogcount) FROM blog WHERE context=$1 AND page=$2" CON PN)
                 `(rss ((version "2.0"))
                       ,(append
                         `(channel
                           (title ,(-> P title))
                           (link  ,(format "http://~a" (-> context host)))
                           (description ,(-> P title)))
                          (let ((row (sqli-fetchrow sqli)))
                            (if (eq? row #f)
                                (begin
                                  (sqli-closer sqli)
                                  '())
                                (let* ((bc (string->number (car row)))
                                       (dc (- bc 10)))
                                  (sqli-query sqli
                                              "SELECT title,dt,blogcount FROM blog WHERE context=$1 AND page=$2 AND blogcount<=$3 AND blogcount>=$4 order by blogcount desc"
                                              CON PN bc dc)
                                  (let ((R (map (lambda (row)
                                                  (apply (lambda (title dt blogcount)
                                                           `(item
                                                             (title ,title)
                                                             (link  ,(-> paths htmllink-full-with-keys 
                                                                         (format "http://~a/servlets/hwiki.scm" (-> context host))
                                                                         'page PN (cons "blogcount" blogcount)))))
                                                         row))
                                                (sqli-fetchall sqli))))
                                    (sqli-closer sqli)
                                    R)))))))))

          (define (create-html)
            (lambda (url)
              (make-response/full 200 "OK, xml" (current-seconds) #"application/xml" null
                                  (list "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
                                        (xexpr->string (rss))))))
          )
         (constructor)
         )
          
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;; Reading the part of the page
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define (read-part context)
          (let ((P (page context (-> context from-where))))
            (if (-> P has-contents? (-> context current-part))
                (-> P contents (-> context current-part))
                "<table><tr><td>~title</td><td>~date</td></tr><td>~piece</td><td>~last</td></tr></table>")))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;; Blog counters
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define (increase-counter context)
          (let ((CON (-> context context))
                (PN  (-> context page-name)))
            (let ((sqli (sqli-provider)))
              (sqli-begin sqli)
              (let ((C (begin
                         (sqli-query sqli "select count(*) from blogcounters where context=$1 AND page=$2" CON PN)
                         (string->number (car (sqli-fetchrow sqli))))))
                (if (= C 0)
                    (sqli-query sqli "insert into blogcounters values($1,$2,0)" CON PN))
                (sqli-query sqli "update blogcounters set blogcount=blogcount+1 where context=$1 and page=$2" CON PN)
                (let ((C (begin
                           (sqli-query sqli "select blogcount from blogcounters where context=$1 and page=$2" CON PN)
                           (string->number (car (sqli-fetchrow sqli))))))
                  (sqli-commit sqli)
                  C)))))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;; Blog page
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define re-date  (pregexp "[~]date"))
        (define re-title (pregexp "[~]title"))
        (define re-piece (pregexp "[~]piece"))
        (define re-last  (pregexp "[~]last"))

        (define (get-blog-page context)
          (if (create-db)
              (let ((sqli     (sqli-provider))
                    (paths    (cfile context))
                    (last10   (make-comment "last10"))
                    (title    (make-comment "title"))
                    (date     (make-comment "date"))
                    (piece    (make-comment "piece"))
                    (form     (lambda (url) (make-comment "form")))
                    (CON      (-> context context))
                    (PN       (-> context page-name))
                    (MAXBLC   0))
                (sqli-begin sqli)
                ;;;; last 10 entries
                (sqli-query sqli "SELECT max(blogcount) FROM blog WHERE context=$1 AND page=$2" CON PN)

                (let ((row (sqli-fetchrow sqli)))

                  (if (string=? (car row) "")
                      (let ((count (increase-counter context))
                            (dt    (current-date))
                            (title "<empty>")
                            (html  "<p>empty blog entry</p>"))
                        (sqli-query sqli "insert into blog(context,page,blogcount,dt,title,html) values($1,$2,$3,$4,$5,$6)"
                                    CON PN count dt title html)
                        (sqli-query sqli "SELECT max(blogcount) FROM blog WHERE context=$1 AND page=$2" CON PN)
                        (set! row (sqli-fetchrow sqli))))

                  (let* ((bc (string->number (car row)))
                         (dc (- bc 10)))
                    (set! MAXBLC bc)
                    (sqli-query sqli
                                "SELECT title,dt,blogcount FROM blog WHERE context=$1 AND page=$2 AND blogcount<=$3 AND blogcount>=$4 order by blogcount desc"
                                CON PN bc dc)
                    (set! last10 (append '((ul))
                                         (map (lambda (row)
                                                (apply (lambda (title dt blogcount)
                                                         `(li
                                                           (div ((class "blog-link"))
                                                                (a ((href ,(-> paths htmllink-with-keys 'page PN (cons "blogcount" blogcount))))
                                                                   ,(format "~a" title)))))
                                                       row))
                                              (sqli-fetchall sqli))))))

                ;;;; current selected blog
                (let ((c (-> context request-value 'blogcount)))
                  (-> context prop! 'blog 'count (if (eq? c #f) MAXBLC (string->number c)))
                  (sqli-query sqli "SELECT title,dt,html FROM blog WHERE context=$1 AND page=$2 AND blogcount=$3" CON PN (-> context prop 'blog 'count))
                  (let ((row (sqli-fetchrow sqli)))
                    (if (not (eq? row #f))
                        (apply (lambda (_title _dt _html)
                                 (set! title (xexpr->string _title))
                                 (set! date  (xexpr->string _dt))
                                 (set! piece _html))
                               row)))

                  ;;;; edit / add
                  (if (-> context logged-in?)
                      (set! form (lambda (url)
                                   `(div ((class "blog-menu"))
                                         "Web log: "
                                         (a ((href ,(-> paths htmllink-with-keys 'page "special:blogedit.html" (cons "page" PN) (cons "blogcount" (-> context prop 'blog 'count) ))))
                                            ,(_ "Edit"))
                                         "  "
                                         (a ((href ,(-> paths htmllink-with-keys 'page "special:blogadd.html" (cons "page" PN))))
                                            ,(_ "Add"))))))

                  ;;;; sqli closer
                  (sqli-commit sqli)
                  (sqli-closer sqli)

                  ;;;; return blog
                  (let ((contents (read-part context)))
                    (set! last10 (xexpr->string (append `(div ((class "last"))) last10)))
                    (set! contents (pregexp-replace re-title contents (lambda (s) title)))
                    (set! contents (pregexp-replace re-date contents (lambda (s) date)))
                    (set! contents (pregexp-replace re-last contents (lambda (s) last10)))
                    (set! contents (pregexp-replace re-piece contents (lambda (s) piece)))
                    
                    (lambda (url)
                      `(div ((class "blog"))
                            ,(form url)
                            ,(make-comment (format "-->~a<!--" contents))
                            )))))
              (lambda (url) (make-comment "No database connection => No blog"))))

        
        (define (plugin:blog context)
          (let ((xexpr (get-blog-page context)))
            (-> context add-extra-header `(link ((rel   "alternate")
                                              (type  "application/rss+xml")
                                              (title "RSS 2.0")
                                              (href  ,(let ((paths (cfile context)))
                                                        (-> paths htmllink-with-keys 'page "special:blogrss.html"
                                                            (cons "page" (-> context page-name))))))))
            (xexpr->string (xexpr (-> context url)))))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;; blog plugin registration
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define (register-plugin-blog)
          (register-plugin 'plugin:blog plugin:blog)
          (register-page "special:blogedit" blog-edit)
          (register-page "special:blogadd"  blog-add)
          (register-page "special:blogrss"  blog-rss)
          )

        )