Commit 8a47f885 authored by amirouche's avatar amirouche

wip sign up form

parent 885be357
......@@ -116,6 +116,54 @@ a:hover {
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 {
display: flex;
border-top: 1px solid black;
......@@ -31,6 +31,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(use-modules (web html))
(use-modules (web mime-types))
(use-modules (web static))
(use-modules (web validate))
(use-modules (web lorem-ipsum))
(setlocale LC_ALL "")
......@@ -50,14 +51,6 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(div (@ (id "wrapper"))
(div (@ (id "container")
(class ,class))
(form (@ (id "navigation"))
(input (@ (id "query")
(name "query")
(type "text")
(autofocus #t)
(value "!overview")))
(input (@ (type "submit")
(value "submit"))))
(div (@ (id "footer")))))))
......@@ -115,20 +108,128 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(define (random-item uid)
((list-ref %items (random (length %items))) uid))
(define (overview)
(template "overview"
`((div (@ (id "overview-intro"))
,(lorem-ipsum 100))
,(map random-item (iota 10))))))
(define (request-query request)
(and=> ((compose uri-query request-uri) request) decode))
(define (query->maybe-response query)
((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)
(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)
(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)
(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)
(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))
(_ (not-found (uri-path (request-uri request))))))
(define-public (main _)
(format #t "Server running @ http://localhost:8080\n")
(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
(fold (lambda (validator errors)
(let ((error ((cdr validator) (assoc-ref alist (car validator)))))
(if (string? error)
(cons (cons (car validator) error) errors)
(define-public (make-valiador . validators)
(lambda (value)
(let loop ((validators validators))
(unless (null? validators)
(let ((out ((car validators) value)))
(if (string=? 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