(module special-edit mzscheme
(require "hwikireq.scm")
(require "page.scm")
(require "config.scm")
(require "context.scm")
(require "users.scm")
(require "template.scm")
(require "plugins.scm")
(provide special:edit)
(define DB-CREATED #f)
(define (create-db)
(if (not DB-CREATED)
(let* ((sqli (sqli-provider)))
(if (not (eq? sqli #f))
(begin
(hlog (format "sqli: after connect to database: ~a" (sqli-error-message sqli)))
(sqli-query sqli "create table register(context varchar,account varchar, page varchar,title varchar,part varchar, file varchar,time timestamp)")
(sqli-query sqli "create index reg_idx_1 on register(context,page,time)")
(sqli-query sqli "create index reg_idx_2 on register(context,account,time)")
(sqli-query sqli "create index reg_idx_3 on register(context,page,part,time)")
(sqli-query sqli "create index reg_idx_4 on register(context,page,part,file,time)")
(sqli-disconnect sqli)
))))
(set! DB-CREATED #t))
(def-class
(this (special:edit context))
(supers (page-base))
(private
(define _template (template 'context context 'name "admin"))
(define (editor part)
(part-editor part))
(define (register-edit page part)
(create-db)
(let* ((sqli (sqli-provider)))
(hlog (format "sqli: after connect to: ~a" (sqli-error-message sqli)))
(sqli-query sqli "insert into register(context,account,page,title,part,file,time) values($1,$2,$3,$4,$5,$6,$7)"
(-> context context)
(-> context user)
(-> page name) (-> page title) (part-name part) (-> page get-part-file part)
(current-date))))
)
(public
(define (get-template)
_template)
(define (edit-page-part P T part)
(debug "page:" (-> P name))
(let ((form (lambda (url)
(adjust-timeout! (edit-timeout))
(let ((form-name "editarea")
(action-name "editsave")
(CSS (-> T css))
(css-classes (apply string-append
(map (lambda (C)
(format "~a=~a;" C C))
(-> T css-classes))))
(contents (-> P contents part)))
(make-response/xhtml
`(html
(head (link ((rel "stylesheet") (href ,(-> _template css)) (type "text/css")))
(title ,(_ "HWiki Editing")))
(body
(form ((enctype "multipart/form-data") (action ,url) (method "post") (name ,form-name))
,(if (eq? (editor part) 'html)
`(input ((type "hidden") (name "editsave") (value "cancel")))
(make-comment "editsave not a hidden thing here")
)
(textarea ((class "editarea") (name "text") ) ,(if (eq? contents #f) "<p></p>" contents) )
,(if (eq? (editor part) 'html)
`(script ((language "javascript") (type "text/javascript") (src "/tinymce/jscripts/tiny_mce/tiny_mce.js")) "")
`(input ((type "submit") (name ,action-name) (value "cancel")))
)
,(if (eq? (editor part) 'html)
`(script ((language "javascript") (type "text/javascript"))
,(string-append "function tinymce_save() { document." form-name "." action-name ".value=\"commit\";document." form-name ".submit(); }"
"function tinymce_cancel() { document." form-name "." action-name ".value=\"cancel\";document." form-name ".submit(); }"
"function setEditorCSS() { tinyMCE.getInstanceById('mce_editor_0').getWin().document.body.className='" (-> context mkdiv (part-name part)) "'; }"
"tinyMCE.init({ theme : \"advanced\", "
"mode : \"textareas\", "
"plugins : \"print,save,table,cancel,media,wikilink\", " "save_enablewhendirty : true, "
"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 "\" "
"});"))
`(input ((type "submit") (name ,action-name) (value "save")))
)
)
)))))))
(let ((bindings (request-bindings (send/suspend form))))
(let ((action (extract-binding/single 'editsave bindings)))
(if (string-ci=? action "cancel")
(create-html)
(begin
(-> P contents! part (extract-binding/single 'text bindings))
(register-edit P part)
(create-html)))))))
(define (create-html)
(debug "create-html:from-where=" (-> context from-where))
(let ((P (page context (-> context from-where))))
(debug "create-html:P:" (-> P name) (-> P title))
(let ((T (-> P get-template)))
(let ((form (lambda (url)
(adjust-timeout! (form-timeout))
(make-response/xhtml
`(html
(head (link ((rel "stylesheet") (href ,(-> _template css)) (type "text/css")))
(title ,(_ "HWiki Editing")))
(body
(div ((class "edit"))
(h1 ,(_ "HWiki Editing"))
(form ((action ,url) (method "post"))
,(append `(table ((class "choose"))
(tr (td ,(_ "Editing: ")) (td (input ((size "40") (type "text") (name "name") (value ,(-> P name)))))
(td (input ((type "submit") (name "%change-page%") (value ,(_ "change name"))))))
(tr (td ,(_ "Template: ")) (td ,(append `(select ((name "template")))
(map (lambda (name)
(if (string-ci=? name (-> T name))
`(option ((value ,name) (selected "selected")) ,name)
`(option ((value ,name)) ,name)))
(-> _template template-names))))
(td (input ((type "submit") (name "%change-template%") (value ,(_ "change template"))))) (td " "))
(tr (td ,(_ "Title: "))
(td ((colspan "2")) (input ((size "40") (type "text") (name "title") (value ,(-> P title)))))
(td (input ((type "submit") (name "%change-title%") (value ,(_ "change title")))))))
(map (lambda (part)
`(tr (td ,(car part)) (td (input ((type "submit") (name ,(car part)) (value ,(_ "edit")))) (td " "))))
(-> T parts))
`((tr ((class "done")) (td " ") (td " ") (td " ") (td (input ((type "submit") (name "%done%") (value ,(_ "done")))))))
)))))))))
(let ((bindings (request-bindings (send/suspend form))))
(let ((done (extract-binding/choice '(%done%) bindings (cons "" "")))
(action (extract-binding/choice (cons '%change-page% (cons '%change-template% (cons '%change-title% (map car (-> T parts))))) bindings (cons "" ""))))
(debug "done:" done)
(debug "action:" action)
(debug "from-where:" (-> context from-where))
(cond ((string-ci=? (cdr done) (_ "done")) (-> context to-from-where))
((string-ci=? (cdr action) (_ "edit")) (edit-page-part P T (-> T get-part (car action))))
((string-ci=? (cdr action) (_ "change title")) (begin
(-> P title! (extract-binding/single 'title bindings))
(create-html)))
((string-ci=? (cdr action) (_ "change template")) (begin
(-> P template! (extract-binding/single 'template bindings))
(create-html)))
((string-ci=? (cdr action) (_ "change name")) (begin
(-> context from-where! (extract-binding/single 'name bindings))
(create-html)))
(else (create-html)))))))))
)
(constructor
(-> supers special!)
)
)
(register-page "special:edit" special:edit)
)