special-login.scm
(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")
                                      ;(adjust-timeout! (menu-timeout))
                                      (let ((paths (cfile context)))
                                        `(div ((class "menu"))
                                              ;(a ((class "mitem") (href ,(-> paths htmllink 'page "special:logout" url))) ,(_ "Logout"))
                                              (a ((class "mitem") (href ,(-> paths htmllink 'page "special:logout"))) ,(_ "Logout"))
                                              ;(a ((class "mitem") (href ,(-> paths htmllink 'page "special:edit" url))) ,(_ "Edit"))
                                              (a ((class "mitem") (href ,(-> paths htmllink 'page "special:edit"))) ,(_ "Edit"))
                                              ;(a ((class "mitem") (href ,(-> paths htmllink 'page "special:upload" url))) ,(_ "Upload"))
                                              (a ((class "mitem") (href ,(-> paths htmllink 'page "special:upload"))) ,(_ "Upload"))
                                              ;(a ((class "mitem") (href ,(-> paths htmllink 'page "special:template" url))) ,(_ "Template"))
                                              (a ((class "mitem") (href ,(-> paths htmllink 'page "special:template"))) ,(_ "Template"))
                                              ;(a ((class "mitem") (href ,(-> paths htmllink 'page "special:prefs" url))) ,(_ "Preferences"))
                                              (a ((class "mitem") (href ,(-> paths htmllink 'page "special:prefs"))) ,(_ "Preferences"))
                                              ;(a ((class "mitem") (href ,(-> paths htmllink 'page "special:cellusage" url))) ,(_ "Cell usage"))
                                              (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" url))) ,(_ "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)


        )