Commit 8a47f885 authored by amirouche's avatar amirouche

wip sign up form

parent 885be357
...@@ -116,6 +116,54 @@ a:hover { ...@@ -116,6 +116,54 @@ a:hover {
text-decoration: underline; text-decoration: underline;
} }
form p {
margin: 0px;
}
form > div.form-item.error {
color: rgb(200, 10, 10);
}
form > div.form-item > p:first-child {
display: flex;
padding: 10px 50px;
margin-bottom: 0px;
padding-bottom: 0px;
}
form > div.form-item > p:first-child > label {
margin-right: 10px;
min-width: 200px;
text-align: right;
}
form > div.form-item > p.error {
padding: 5px 50px;
margin: 0px;
font-size: 0.7em;
text-align: right;
line-height: 1em;
}
form input[type="text"],
form input[type="password"] {
width: 100%;
border: 1px solid hsla(0, 0%, 70%, 1);
border-radius: 2px;
background: white;
}
form .error input[type="text"],
form .error input[type="password"] {
box-shadow: 0px 0px 2px rgb(200, 10, 10);
border: 1px solid rgb(200, 10, 10);
}
form > div.form-item > p.form-control {
display: flex;
justify-content: right;
}
#navigation { #navigation {
display: flex; display: flex;
border-top: 1px solid black; border-top: 1px solid black;
......
...@@ -31,6 +31,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -31,6 +31,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(use-modules (web html)) (use-modules (web html))
(use-modules (web mime-types)) (use-modules (web mime-types))
(use-modules (web static)) (use-modules (web static))
(use-modules (web validate))
(use-modules (web lorem-ipsum)) (use-modules (web lorem-ipsum))
(setlocale LC_ALL "") (setlocale LC_ALL "")
...@@ -50,14 +51,6 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -50,14 +51,6 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(div (@ (id "wrapper")) (div (@ (id "wrapper"))
(div (@ (id "container") (div (@ (id "container")
(class ,class)) (class ,class))
(form (@ (id "navigation"))
(input (@ (id "query")
(name "query")
(type "text")
(autofocus #t)
(value "!overview")))
(input (@ (type "submit")
(value "submit"))))
,body)) ,body))
(div (@ (id "footer"))))))) (div (@ (id "footer")))))))
...@@ -115,20 +108,128 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@" ...@@ -115,20 +108,128 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(define (random-item uid) (define (random-item uid)
((list-ref %items (random (length %items))) uid)) ((list-ref %items (random (length %items))) uid))
(define (overview) (define (request-query request)
(render-html (and=> ((compose uri-query request-uri) request) decode))
(template "overview"
`((div (@ (id "overview-intro")) (define (query->maybe-response query)
,(lorem-ipsum 100)) (cond
,(map random-item (iota 10)))))) ((not query) (values #f #f))
((null? query) (values #f #f))
((string=? (car query) "/login") (redirect "/login"))
((string=? (car query) "/signup") (redirect "/signup"))))
(define (index request)
(let ((query (assoc-ref (request-query request) "query")))
(call-with-values (lambda () (query->maybe-response query))
(lambda (header body)
(if header
(values header body)
(render-html
(template "overview"
`((form (@ (id "navigation"))
(input (@ (id "query")
(name "query")
(type "text")
(autofocus #t)))
(input (@ (type "submit")
(value "submit"))))
(div (@ (id "overview-intro"))
,(lorem-ipsum 100))
,(map random-item (iota 10))))))))))
(define sxml->response render-html)
(define (login/get request)
(sxml->response
(template "login"
`(form (@ (method "POST"))
(h2 "Log in")
(p (label "login")
(input (@ (name "login")
(type "text"))))
(p (label "password")
(input (@ (name "password")
(type "password"))))
(p (@ (class "form-control"))
(input (@ (type "submit")
(value "submit"))))))))
(define (login/post request body)
...)
(define (maybe-error error)
(if error
`(p (@ (class "error")) ,error)
'()))
(define (alist->class alist)
"Create html class attribute with an ALIST"
(let loop ((alist alist)
(out ""))
(if (null? alist)
out
(if (cdar alist)
(loop (cdr alist) (string-append (caar alist) " " out))
(loop (cdr alist) out)))))
(define (signup/template errors)
(let ((login-error (assoc-ref errors "login"))
(password-error (assoc-ref errors "password"))
(confirmation-error (assoc-ref errors "confirmation")))
(template "login"
`(form (@ (method "POST"))
(h2 "Sign up")
(div (@ (class ,(alist->class `(("form-item" . #t)
("error" . ,login-error)))))
(p (label "login")
(input (@ (name "login")
(type "text"))))
,(maybe-error login-error))
(div (@ (class ,(alist->class `(("form-item" . #t)
("error" . ,password-error)))))
(p (label "password")
(input (@ (name "password")
(type "password")))))
(div (@ (class ,(alist->class `(("form-item" . #t)
("error" . ,confirmation-error)))))
(p (label "confirmation")
(input (@ (name "confirmation")
(type "password")))))
(div (@ (class "form-item"))
(p (@ (class "form-control"))
(input (@ (type "submit")
(value "submit")))))))))
(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 (password-valid? password)
#t) ;; TODO
(define %signup `(("login" . ,login-valid?)
("password" . ,password-valid?)))
(define (signup/post request body)
(let ((form (decode body)))
(let ((errors (pk 'errors (validate %signup form))))
(if (null? errors)
(redirect "/")
(sxml->response (signup/template errors))))))
(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) (overview)) ('(GET) (index request))
('(GET "login") (login/get request))
('(POST "login") (login/post request post))
('(GET "signup") (signup/get request))
('(POST "signup") (signup/post request body))
(('GET "static" path ...) (render-static-asset path)) (('GET "static" path ...) (render-static-asset path))
(_ (not-found (uri-path (request-uri request)))))) (_ (not-found (uri-path (request-uri request))))))
(define-public (main _) (define-public (main _)
(format #t "Server running @ http://localhost:8080\n") (format #t "Server running @ http://localhost:8080\n")
(run-server handler)) (run-server handler))
(define-module (web validate))
(use-modules ((srfi srfi-1)))
(define-public (validate spec alist)
"Validate ALIST based using SPEC
SPEC must be an association list that maps keys to validation
procedures. Validation procedure must take a single parameter that
will be the associated value in ALIST based on equal?. The validation
procedure must return an error message as string if the value is
invalid"
(fold (lambda (validator errors)
(let ((error ((cdr validator) (assoc-ref alist (car validator)))))
(if (string? error)
(cons (cons (car validator) error) errors)
errors)))
'()
spec))
(define-public (make-valiador . validators)
(lambda (value)
(let loop ((validators validators))
(unless (null? validators)
(let ((out ((car validators) value)))
(if (string=? out)
out
(loop (cdr validators))))))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment