...
 
Commits (6)
...@@ -151,6 +151,7 @@ form input[type="password"] { ...@@ -151,6 +151,7 @@ form input[type="password"] {
border: 1px solid hsla(0, 0%, 70%, 1); border: 1px solid hsla(0, 0%, 70%, 1);
border-radius: 2px; border-radius: 2px;
background: white; background: white;
padding: 5px 10px;
} }
form .error input[type="text"], form .error input[type="text"],
......
...@@ -35,7 +35,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -35,7 +35,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(use-modules ((web style))) (use-modules ((web style)))
(use-modules ((web validate))) (use-modules ((web validate)))
(setlocale LC_ALL "") ;; (setlocale LC_ALL "")
;;; ;;;
...@@ -100,7 +100,6 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -100,7 +100,6 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(p (@ (class "overview-item-description")) (p (@ (class "overview-item-description"))
"Published yesterday in presence"))) "Published yesterday in presence")))
(define %items (list random-post (define %items (list random-post
random-message random-message
random-link random-link
...@@ -116,7 +115,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -116,7 +115,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(cond (cond
((not query) (values #f #f)) ((not query) (values #f #f))
((null? query) (values #f #f)) ((null? query) (values #f #f))
((string=? (car query) "/login") (redirect "/login")) ((string=? (car query) "/signin") (redirect "/signin"))
((string=? (car query) "/signup") (redirect "/signup")))) ((string=? (car query) "/signup") (redirect "/signup"))))
(define (index request) (define (index request)
...@@ -140,13 +139,13 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -140,13 +139,13 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(define sxml->response render-html) (define sxml->response render-html)
(define (login/get request) (define (signin/get request)
(sxml->response (sxml->response
(template "login" (template "signin"
`(form (@ (method "POST")) `(form (@ (method "POST"))
(h2 "Log in") (h2 "Log in")
(p (label "login") (p (label "signin")
(input (@ (name "login") (input (@ (name "signin")
(type "text")))) (type "text"))))
(p (label "password") (p (label "password")
(input (@ (name "password") (input (@ (name "password")
...@@ -155,7 +154,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -155,7 +154,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(input (@ (type "submit") (input (@ (type "submit")
(value "submit")))))))) (value "submit"))))))))
(define (login/post request body) (define (signin/post request body)
...) ...)
(define (maybe-error error) (define (maybe-error error)
...@@ -174,21 +173,18 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -174,21 +173,18 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(loop (cdr alist) out))))) (loop (cdr alist) out)))))
(define (signup/template errors) (define (signup/template errors)
(let ((login-error (assoc-ref errors "login")) (let ((username-error (assoc-ref errors "username"))
(password-error (assoc-ref errors "password")) (password-error (assoc-ref errors "password"))
(confirmation-error (assoc-ref errors "confirmation"))) (confirmation-error (assoc-ref errors "confirmation")))
(template "signup" (template "signup"
`(form (@ (method "POST") `(form (@ (method "POST"))
(style ,(make-style
`((border . ("1px" solid (hsla 300 50 50 1)))
(background . (hsla 200 50 50 1))))))
(h2 "Sign up") (h2 "Sign up")
(div (@ (class ,(make-class `(("form-item" . #t) (div (@ (class ,(make-class `(("form-item" . #t)
("error" . ,login-error))))) ("error" . ,username-error)))))
(p (label "login") (p (label "username")
(input (@ (name "login") (input (@ (name "username")
(type "text")))) (type "text"))))
,(maybe-error login-error)) ,(maybe-error username-error))
(div (@ (class ,(make-class `(("form-item" . #t) (div (@ (class ,(make-class `(("form-item" . #t)
("error" . ,password-error))))) ("error" . ,password-error)))))
(p (label "password") (p (label "password")
...@@ -207,19 +203,23 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -207,19 +203,23 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(define (signup/get request) (define (signup/get request)
(sxml->response (signup/template '()))) (sxml->response (signup/template '())))
(define (login-valid? login) (define (username-valid? username)
(and (eq? (string-length (car login)) 0) (and (or (not username)
"Password must be at least one character")) (eq? (string-length (car username)) 0))
"username must be at least one character"))
(define (password-valid? password) (define (password-valid? password)
#t) ;; TODO (and (not password)
;; TODO: implement password strength
"password is required"))
(define %signup `(("login" . ,login-valid?) (define %signup `(("username" . ,username-valid?)
("password" . ,password-valid?))) ("password" . ,password-valid?)))
(define (signup/post request body) (define (signup/post request body)
(let ((form (decode body))) (let ((form (decode body)))
(let ((errors (pk 'errors (validate %signup form)))) (let ((errors (validate %signup form)))
;; TODO: implement deep validation
(if (null? errors) (if (null? errors)
(redirect "/") (redirect "/")
(sxml->response (signup/template errors)))))) (sxml->response (signup/template errors))))))
...@@ -227,8 +227,8 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -227,8 +227,8 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(define (handler request body) (define (handler request body)
(match (cons (request-method request) (request-path-components request)) (match (cons (request-method request) (request-path-components request))
('(GET) (index request)) ('(GET) (index request))
('(GET "login") (login/get request)) ('(GET "signin") (signin/get request))
('(POST "login") (login/post request post)) ('(POST "signin") (signin/post request post))
('(GET "signup") (signup/get request)) ('(GET "signup") (signup/get request))
('(POST "signup") (signup/post request body)) ('(POST "signup") (signup/post request body))
(('GET "static" path ...) (render-static-asset path)) (('GET "static" path ...) (render-static-asset path))
......
...@@ -542,10 +542,8 @@ ...@@ -542,10 +542,8 @@
(define (file-extension file-name) (define (file-extension file-name)
"Return the file extension for FILE-NAME, or #f if one is not "Return the file extension for FILE-NAME, or #f if one is not
found." found."
(and=> (regexp-exec %file-ext-regexp file-name) (let ((strings (string-split file-name #\.)))
(lambda (match) (list-ref strings (- (length strings) 1))))
(or (match:substring match 2)
(match:substring match 1)))))
(define-public (mime-type file-name) (define-public (mime-type file-name)
"Guess the MIME type for FILE-NAME based upon its file extension." "Guess the MIME type for FILE-NAME based upon its file extension."
......
...@@ -34,7 +34,7 @@ ...@@ -34,7 +34,7 @@
(define-public (render-static-asset path) (define-public (render-static-asset path)
(if (valid? path) (if (valid? path)
;; XXX: the requested file is translated into a filpath related to where ;; XXX: the requested file is translated into a filepath related to where
;; the server is executed. ;; the server is executed.
(let ((filename (string-join (cons* (getcwd) "static" path) (let ((filename (string-join (cons* (getcwd) "static" path)
"/"))) "/")))
......