(define-structure surflet surflet-interface (open surflets xml-i/o send-xml srfi-1 scheme-with-scsh) (begin (define users "../htdocs/users.xml") (define (get-login user) (cdadr user)) (define (get-passwd user) (cdaddr user)) (define (create-user-expr login passwd) `((user (login ,login) (password ,passwd)))) (define (create-user login passwd) `(user (login ,login) (password ,passwd))) (define check-login (lambda (login passwd) (let ((auser (create-user login passwd)) (allusers (get-list users))) (member auser allusers)))) (define list-length (lambda (list) (if (null? list) 0 (+ 1 (list-length (cdr list)))))) (define (get-list filename) (cdaddr (read-xml-from-file filename))) (define (send-users-info) (let* ((xml (read-xml-from-file users)) (xmlxsl `(,(cadr xml) (*PI* xml-stylesheet "href=\"/users.xsl\" type=\"text/xsl\"") ,(cddr xml)))) (send-xml/finish xmlxsl))) (define (logout-page) (send-html/finish `( (plain-html "") (html (body (h1 "Your are logged out now!") (p (a (@ (href "index3.scm")) "Login Page"))))))) (define (insert-a-user login passwd) (let* ((new-user (create-user-expr login passwd)) (users-old-xml (read-xml-from-file users)) (users-new-xml `(*TOP* (,(car (cdr users-old-xml))) (users ,@(append (cdr (car (cddr users-old-xml))) new-user))))) (write-xml-to-file users users-new-xml))) (define (create-a-user-page) (let* ((login-input (make-text-field)) (password-input (make-password-field)) (submit-button (make-submit-button "Submit")) (req (send-html/suspend (lambda (k-url) `((plain-html "") (html (body (h1 "Create a new user") (surflet-form ,k-url POST (table (tr (td "Login:") (td ,login-input)) (tr (td "Password:") (td ,password-input)) (tr (td ,submit-button)))))))))) (bindings (get-bindings req)) (login (input-field-value login-input bindings)) (passwd (input-field-value password-input bindings)) ) (insert-a-user login passwd) (req (send-html/suspend (lambda (k-url) `( (plain-html "") (html (body (p "User " (b ,login) "has been created!"))))))) (logged))) (define (delete-a-user-page login) (delete-a-user login) (let ((req (send-html/suspend (lambda (k-url) `( (plain-html "") (html (body (p "User " (b ,login) "has been deleted!")))))))) (logged))) (define (delete-a-element elem old-list) (if (null? old-list) '() (let ((user (car old-list)) (users (cdr old-list))) (if (equal? elem (get-login user)) `(,(delete-a-element elem users)) ;skip `( ,user ,(delete-a-element elem users)) )))) (define (delete-a-user login) (let* ((users-list (delete-a-element login (get-list users))) (users-new-xml `(*TOP* (*PI* xml "version=\"1.0\"") (users (,users-list))))) (write-xml-to-file users users-new-xml))) (define (admin-view-page) (let* ((login-url (make-annotated-address)) (req (send-xml/suspend (lambda (k-url) (let* ((xml (read-xml-from-file users)) (xml-url `(,(car xml) ,(cadr xml) ,(add-delete-tag (caddr xml) login-url k-url))) (xmlxslt `(,(car xml-url) ,(cadr xml-url) (*PI* xml-stylesheet "href=\"/users_admin.xsl \" type=\"text/xsl\"") ,(cddr xml-url)))) (cdr xmlxslt))))) (bindings (get-bindings req))) (case-returned-via (get-bindings req) ((login-url) => (lambda (login) (delete-a-user-page login)))))) (define (add-delete-tag users-list login-url k-url) (let ((add-url (lambda (user) (let ((login (get-login user))) (append user `((login-url ,(login-url k-url login)))))))) `(,(car users-list) ,(map add-url (cdr users-list))))) (define (left-frame-page) (let* ((logout (make-address)) (send-users (make-address)) (create-a-user (make-address)) (admin-view (make-address)) (req (send-html/suspend (lambda (k-url) `((plain-html "") (html (head (title "User Administration")) (body (h3 "Administration Menu") (table (tr (td (a (@ (href ,(send-users k-url)) (target "right")) "Normal View"))) (tr (td (a (@ (href ,(create-a-user k-url)) (target "right")) "Create User"))) (tr (td (a (@ (href ,(admin-view k-url)) (target "right")) "Admin View")))) (hr) (a (@ (href ,(logout k-url)) (target "_parent")) "LOGOUT"))))))) (bindings (get-bindings req))) (case-returned-via bindings ((logout) (logout-page)) ((send-users) (send-users-info)) ((create-a-user) (create-a-user-page)) ((admin-view) (admin-view-page)) ))) (define (login-failed-page) (send-html/finish `( (plain-html "") (html (body (h1 "Login failed") (p (i "Number of registered users are ") (b ,(list-length (get-list users))) (i " and still login login failed! Haha .. what a pity ... you call yourself a hacker ... hahaaa!!")) (p (a (@ (href "index3.scm")) "Login Page"))))))) (define (login) (let* ((login-input (make-text-field)) (password-input (make-password-field)) (submit-button (make-submit-button "Submit")) (req (send-html/suspend (lambda (k-url) `((plain-html "") (html (body (h1 "Login Portal") (surflet-form ,k-url POST (table (tr (td "Login:") (td ,login-input)) (tr (td "Password:") (td ,password-input)) (tr (td ,submit-button)))))))))) (bindings (get-bindings req)) (login (input-field-value login-input bindings)) (passwd (input-field-value password-input bindings)) ) (check-login login passwd))) (define (logged) (let* ((left-frame (make-address)) (right-frame (make-address)) (req (send-html/suspend (lambda (k-url) `((plain-html "") (html (head (title "User Administration")) (frameset (@(cols "150,*")) (frame (@ (name "left") (src ,(left-frame k-url)))) (frame (@ (name "right") (src ,(right-frame k-url)))))))))) (bindings (get-bindings req))) (case-returned-via bindings ((left-frame) (left-frame-page)) ((right-frame) (send-users-info))))) (define (main req) (if (login) (logged) (login-failed-page))) ))