(module special-login mzscheme
(require "hwikireq.scm")
(require "page.scm")
(require "config.scm")
(require "context.scm")
(require "users.scm")
(require "template.scm")
(def-class
(this (special:login context))
(supers (page-base))
(private
(define _template (template 'context context 'name "admin"))
(define _users (users context))
)
(public
(define (get-template) _template)
(define (create-html)
(display "special:login:create-html\n")
(let ((form (lambda (url)
(display "special:login:form\n")
(adjust-timeout! (form-timeout))
(make-response/xhtml
`(html
(head (link ((rel "stylesheet") (href ,(-> _template css)) (type "text/css")))
(title ,(_ "HWiki login")))
(body
(div ((class "login"))
(h1 ,(_ "HWiki login"))
(form ((action ,url) (method "post"))
(table (tr (td ,(_ "Account :")) (td ((colspan "2")) (input ((type "text") (name "account")))))
(tr (td ,(_ "Password :")) (td ((colspan "2"))(input ((type "password") (name "password")))))
(tr ((class "done")) (td " ")
(td ((class "tdbutton")) (input ((type "submit") (class "button") (name "submit") (value ,(_ "cancel")))))
(td ((class "tdbutton")) (input ((type "submit") (class "button") (name "submit") (value ,(_ "login"))))))
)))))))))
(let ((bindings (request-bindings (send/suspend form)))
(paths (cfile context)))
(debug "LOGIN-GET-VARIABLES")
(let ((submit (extract-binding/single 'submit bindings))
(account (extract-binding/single 'account bindings))
(password (extract-binding/single 'password bindings)))
(if (string-ci=? submit "cancel")
(lambda (url)
(display "special:login:cancel\n")
(adjust-timeout! (form-timeout))
(make-response/xhtml
`(html
(head (link ((rel "stylesheet") (href ,(-> _template css)) (type "text/css")))
(title ,(_ "HWiki login - canceled")))
(body
(h1 ,(_ "HWiki Login - Canceled"))
(a ((href ,(-> paths htmllink 'page (-> context from-where))))
,(_ "Return to previous page."))))))
(let ((role (-> _users check account password)))
(let ((logged-in (if (eq? role 'not-found) (_ "User doesn't exist")
(if (eq? role 'wrong-pass) (_ "Wrong password") #t))))
(if (eq? logged-in #t)
(begin
(display (format "login:context=~a~%" (-> context context)))
(-> context logged-in? #t)
(-> context role role)
(-> context user! account)
(-> context register-part role
(lambda (context url)
(display "special:login:ok\n")
(let ((paths (cfile context)))
`(div ((class "menu"))
(a ((class "mitem") (href ,(-> paths htmllink 'page "special:logout"))) ,(_ "Logout"))
(a ((class "mitem") (href ,(-> paths htmllink 'page "special:edit"))) ,(_ "Edit"))
(a ((class "mitem") (href ,(-> paths htmllink 'page "special:upload"))) ,(_ "Upload"))
(a ((class "mitem") (href ,(-> paths htmllink 'page "special:template"))) ,(_ "Template"))
(a ((class "mitem") (href ,(-> paths htmllink 'page "special:prefs"))) ,(_ "Preferences"))
(a ((class "mitem") (href ,(-> paths htmllink 'page "special:cellusage"))) ,(_ "Cell usage"))
,(if (eq? (-> context role) 'admin)
`(a ((class "mitem") (href ,(-> paths htmllink 'page "special:admin"))) ,(_ "Admin"))
(make-comment "Not administrator"))))))
(-> context logged-in!))
(lambda (url)
(display "special:login:problem\n")
(adjust-timeout! (form-timeout))
(make-response/xhtml
`(html
(head (link ((rel "stylesheet") (href ,(-> _template css)) (type "text/css")))
(title ,(_ "HWiki login - error")))
(body
(h1 ,(_ "HWiki Login - Error"))
(div ((class "error"))
(p ,logged-in)
(a ((href ,(-> paths htmllink 'page (-> context from-where))))
,(_ "Return to previous page.")))))))))))))))
)
(constructor
(-> supers special!)
)
)
(register-page "special:login" special:login)
(register-page "special-login" special:login)
)