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