(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)))))
(def-class
(this (blog-page-base context))
(supers (page-base))
(private
(define _template (template 'context context 'name "admin"))
)
(public
(define (get-template) _template)
(define (css) (-> _template css))
(define (title) (_ "HWiki - Edit Web Log Entry"))
(define (edit-current)
(let ((sqli (sqli-provider))
(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))
)
(-> context make-response/xhtml
`(html
,(-> supers create-header context)
(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\", " "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)))))))
)
(constructor)
)
(define (add-entry context)
(-> context to-from-where))
(define (remove-entry context)
(-> context to-from-where))
(def-class
(this (blog-edit context))
(supers (blog-page-base context))
(private
)
(public
(define (create-html)
(if (not (-> context role-editor?))
(-> supers not-autorized context
`(p (_ "You must be logged in at least as an 'editor' to be able to edit web logs")))
(begin
(-> context prop! 'blog 'count (string->number (-> context request-value 'blogcount)))
(-> context prop! 'blog 'page (-> context request-value 'page))
(let ((contents (-> supers edit-current)))
(-> context to-from-where)))
))
)
(constructor
(-> supers special!)
))
(def-class
(this (blog-add context))
(supers (blog-page-base context))
(private
)
(public
(define (create-html)
(if (not (-> context role-editor?))
(-> supers not-autorized context
`(p (_ "You must be logged in at least as an 'editor' to be able to edit web logs")))
(begin
(-> context prop! 'blog 'page (-> context request-value 'page))
(-> context prop! 'blog 'count (let ((pn (-> context page-name)))
(-> context page-name! (-> context prop 'blog 'page))
(increase-counter context)
(-> context page-name pn)))
(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 (-> supers edit-current)))
(-> context to-from-where)))
))
)
(constructor
(-> supers special!)
)
)
(def-class
(this (blog-rss context))
(supers)
(private)
(public
(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)
)
(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>")))
(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)))))
(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)
(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))))))
(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)))
(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-commit sqli)
(sqli-closer sqli)
(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)))))
(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)
)
(register-plugin-blog)
)
![[logo]](/logo.png){kind=logo}