...
 
Commits (16)
  • amirouche's avatar
    cosmit · 7e2bcb49
    amirouche authored
    7e2bcb49
  • amirouche's avatar
    typofix · 57b30c27
    amirouche authored
    57b30c27
  • amirouche's avatar
    typofix · 5b777d43
    amirouche authored
    5b777d43
  • amirouche's avatar
    26160b05
  • amirouche's avatar
    argon2: update to 0~20161029-1 (ubuntu 17.10) · 54d99366
    amirouche authored
    - add %argon-type-argon2-d, %argon-type-argon2-i, %argon-type-argon2-id private variables
    - encoded-length: add argon-type parameter
    - hash-secret: change urandom parameter to be the relevant variable
    - hash-secret: pass %argon-type-argon2-i as argon-type argument to encoded-length
    54d99366
  • amirouche's avatar
    .dir-locals.el: add template · 394b91d8
    amirouche authored
    394b91d8
  • amirouche's avatar
    html: add sxml/maybe · d3b37dd0
    amirouche authored
    d3b37dd0
  • amirouche's avatar
    .gitignore: add src/wt/ · 3dc9b3ef
    amirouche authored
    3dc9b3ef
  • amirouche's avatar
    style: move make-class · d543c835
    amirouche authored
    d543c835
  • amirouche's avatar
    doc++ · 4032aadd
    amirouche authored
    4032aadd
  • amirouche's avatar
    cosmit · d0117e8d
    amirouche authored
    d0117e8d
  • amirouche's avatar
    cosmit · 7600ba94
    amirouche authored
    7600ba94
  • amirouche's avatar
    css: rename form-item to form-field · 3153de2b
    amirouche authored
    3153de2b
  • amirouche's avatar
    helpers: rename render-html to sxml->response · 0fdb05b8
    amirouche authored
    0fdb05b8
  • amirouche's avatar
    helpers: add cookies helpers. · cbe0db05
    amirouche authored
    - Add a #:cookies key parameter to 'redirect' that allows to set
      cookies. This is done in 'redirect' because it seems to me that
      settings cookies is only useful after a form a successful POST
      request and POST requests must always be followed by a redirect to
      avoid buggy request replay (via page refresh).
    
    - Add 'request-cookies' public procedure.
    cbe0db05
  • amirouche's avatar
    complete sign up and sign in paths · a2599b01
    amirouche authored
    - app: Add module with a 'app' record, to store application wide
      variables. It has only a pepper (aka. 'secret' in some other
      frameworks) field right.
    
    - web: import 'make-hash', 'string-sign' and 'string-verify' which allow to
      sign strings. It's used to validated cookie values.
    
    - web: add 'log-debug' and 'log-info' procedures
    
    - web: add 'rm', 'set', 'ref', 'set*' and 'ref*' procedures to help with
      association lists that have strings as keys.
    
    - web: replace render-html with sxml->response
    
    - web: index: display a welcome message if an user is logged in
    
    - web: create 'form/input' and 'form/submit' for consistent forms with
      label, value and error handling.
    
    - web: add query-user-by-username, query-user-by-uid and request-user
    
    - web: signin and signup: refactor to make use for 'form/input' and
      'form/submit', shallow and deep input validation (in particular add
      'strong?' password predicate), set 'token' cookie when the user sign in.
    a2599b01
......@@ -22,4 +22,5 @@
(put 'with-cnx 'scheme-indent-function 1)
;; others
(put 'match 'scheme-indent-function 1)
(put 'template 'scheme-indent-function 1)
)))))
(define-module (app))
(use-modules ((srfi srfi-9)))
(define-record-type <app>
(make-app pepper)
app?
(pepper app-pepper))
(export make-app)
(export app-pepper)
......@@ -17,6 +17,8 @@
;;
;; https://martinfowler.com/articles/web-security-basics.html
;;
;; argon2 version 0~20161029-1
;;
(define-module (argon2))
(use-modules (ice-9 binary-ports))
......@@ -46,7 +48,11 @@
(let ((function (dynamic-func function-name shared-object)))
(pointer->procedure return-value function arguments)))))
(define argon2 (dynamic-link* "/usr/lib/x86_64-linux-gnu/libargon2.so"))
(define argon2 (dynamic-link* "/usr/lib/x86_64-linux-gnu/libargon2.so")) ;; TODO
(define %argon-type-argon2-d 0)
(define %argon-type-argon2-i 1)
(define %argon-type-argon2-id 2)
(define error-message
(let ((func (argon2 '*
......@@ -62,9 +68,10 @@
uint32
uint32
uint32
uint32)))
(lambda (time-cost memory-cost parallelism salt-length hash-length)
(func time-cost memory-cost parallelism salt-length hash-length))))
uint32
int)))
(lambda (time-cost memory-cost parallelism salt-length hash-length argon-type)
(func time-cost memory-cost parallelism salt-length hash-length argon-type))))
(define argon2i-hash-encode
(let ((func (argon2 int
......@@ -98,16 +105,17 @@
(define-public (hash-secret password pepper)
"Hash PASSWORD and PEPPER"
(let ((password* (string-append password pepper)))
(let ((time-cost 2) ;; default values from argon2_cffi
(memory-cost 512)
(parallelism 2)
(length 16)
(salt (urandom 16)))
(let* ((time-cost 2) ;; default values from argon2_cffi
(memory-cost 512)
(parallelism 2)
(length 16)
(salt (urandom length)))
(let ((total (encoded-length time-cost
memory-cost
parallelism
length
length)))
length
%argon-type-argon2-i)))
(utf8->string (argon2i-hash-encode time-cost
memory-cost
parallelism
......@@ -124,10 +132,15 @@
(define-public (verify encoded password pepper)
"Verify that ENCODED is really associated with PASSWORD and PEPPER"
(let ((password* (string->utf8 (string-append password pepper)))
(let ((password* (string->utf8 (string-append password pepper))))
(let ((out (argon2i-verify (bytevector->pointer (string->utf8 encoded))
(bytevector->pointer password*)
(bytevector-length password*))))
(if (zero? out)
#t
(throw 'argon2 (error-message out))))))
(define-public (verify* encoded password pepper)
(catch 'argon2
(lambda () (verify encoded password pepper))
(const #f)))
......@@ -120,24 +120,24 @@ form p {
margin: 0px;
}
form > div.form-item.error {
form > div.form-field.error {
color: rgb(200, 10, 10);
}
form > div.form-item > p:first-child {
form > div.form-field > p:first-child {
display: flex;
padding: 10px 50px;
margin-bottom: 0px;
padding-bottom: 0px;
}
form > div.form-item > p:first-child > label {
form > div.form-field > p:first-child > label {
margin-right: 10px;
min-width: 200px;
text-align: right;
}
form > div.form-item > p.error {
form > div.form-field > p.error {
padding: 5px 50px;
margin: 0px;
font-size: 0.7em;
......@@ -160,7 +160,7 @@ form .error input[type="password"] {
border: 1px solid rgb(200, 10, 10);
}
form > div.form-item > p.form-control {
form > div.form-field > p.form-control {
display: flex;
justify-content: right;
}
......@@ -175,7 +175,6 @@ form > div.form-item > p.form-control {
#query {
border: 0px solid black;
text-align: center;
flex-grow: 2;
box-sizing: border-box;
font-family: hack, mono, monospace;
......
......@@ -21,6 +21,8 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
;; stdlib
(use-modules ((ice-9 match)))
(use-modules ((rnrs bytevectors)))
(use-modules ((srfi srfi-1)))
(use-modules ((web request)))
(use-modules ((web server)))
(use-modules ((web uri)))
......@@ -28,10 +30,10 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
;; third party
(use-modules ((wiredtiger extra)))
(use-modules ((wiredtiger feature-space)))
(use-modules ((wiredtiger grf3)))
(use-modules ((wiredtiger grf3) #:prefix grf3:))
(use-modules ((wiredtiger wiredtiger)))
;; local
;; wanna be guile modules
(use-modules ((web decode)))
(use-modules ((web helpers)))
(use-modules ((web html)))
......@@ -41,8 +43,80 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(use-modules ((web style)))
(use-modules ((web validate)))
;; local
(use-modules ((sha-2)))
(use-modules ((argon2)))
(use-modules ((app)))
(setlocale LC_ALL "")
;;; sign
(define (make-hash string pepper)
(let ((hash (make-sha-256)))
(sha-256-update! hash (string->utf8 string))
(sha-256-update! hash (string->utf8 pepper))
(sha-256-finish! hash)
(sha-256->string hash)))
(define (string-sign string pepper)
(let ((hash (make-hash string pepper)))
(string-append string "$" hash)))
(define (string-verify string pepper)
(match (string-split string #\$)
((value signature)
;; TODO: subject to timing attack, use constant time comparison
(if (string=? signature (make-hash value pepper)) value #f))
(_ #f)))
;;; logging
(define (%log level) ;; TODO: add colors and env variable
(lambda (message . args)
(format #t "~a: ~a: " (current-time) level)
(apply format #t message args)
(newline)))
(define log-debug (%log 'debug))
(define log-info (%log 'info))
;;; wiredtiger helpers
(define (grf3:find key value) ;; TODO: move to wiredtiger
(map grf3:get (fs:find key value)))
;;; alist helpers using equal?
(define (rm alist key)
(alist-delete key alist))
(define (set alist key value)
(acons key value (rm alist key)))
(define ref assoc-ref)
;; TODO: rm*
(define (ref* alist . keys)
(let loop ((keys keys)
(alist alist))
(cond
((eq? alist #f) #f)
((null? keys) alist)
(else (loop (cdr keys) (ref alist (car keys)))))))
(define (set* alist . args)
(let* ((args* (reverse args))
(value (car args*))
(keys (reverse (cdr args*))))
(let loop ((keys keys)
(alist alist))
(if (null? keys)
value
(set alist (car keys) (loop (cdr keys) (or (ref alist (car keys)) '())))))))
;;;
(define (template class body)
......@@ -50,7 +124,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(html
(head
(meta (@ (charset "utf-8")))
(title "presence mockup")
(title "culturia")
(link (@ (rel "stylesheet") (href "/static/normalize.css")))
(link (@ (rel "stylesheet") (href "/static/main.css"))))
(body
......@@ -117,131 +191,281 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
(define (request-query request)
(and=> ((compose uri-query request-uri) request) decode))
(define (query->maybe-response query)
(define (query->maybe-response query user)
(cond
((not query) (values #f #f))
((null? query) (values #f #f))
((string=? (car query) "/signin") (redirect "/signin"))
((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))
(define (index app request)
(let ((query (assoc-ref (request-query request) "query"))
(user (request-user request app)))
(call-with-values (lambda () (query->maybe-response query user))
(lambda (header body)
(if header
(values header body)
(render-html
(sxml->response
(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)
`(,(sxml/maybe (and user `((p "Héllo " ,(grf3:vertex-ref user 'user/username)))))
(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))))))))))
;;; form helpers
(define (form/input type name label value error)
`(div (@ (class ,(make-class `(("form-field" . #t)
("error" . ,error)))))
(p (label (@ (for ,name)) ,label)
(input (@ (type ,type)
(id ,name)
(name ,name)
(value ,(if value (car value) ""))))
,(sxml/maybe (and error `(p (@ (class "error")) ,error))))))
(define (form/submit value)
`(div (@ (class "form-field"))
(p (@ (class "form-control"))
(input (@ (type "submit") (value ,value))))))
;;; queries
(define (query-user-by-username username)
"Return the vertex associated with USERNAME otherwise #f."
(let ((out (grf3:find 'user/username username)))
(if (null? out)
#f
(car out)))) ;; XXX: (user/username . username) must be unique
(define (query-user-by-uid uid)
(and=> (grf3:get uid)
(lambda (user)
(and (eq? (grf3:vertex-ref user 'type) 'user) user))))
(define (request-user request app)
(and=> (assq-ref (request-cookies request) 'token)
(lambda (token)
(and=> (string-verify token (app-pepper app))
query-user-by-uid))))
;;; signin
(define (signin/template values errors)
(template "signin"
`(form (@ (method "POST"))
(h2 "Sign in")
,(form/input "text"
"username"
"username"
(ref values "username")
(ref errors "username"))
,(form/input "password"
"password"
"password"
#f
(ref errors "password"))
,(form/submit "submit"))))
(define (signin/get request)
(sxml->response
(template "signin"
`(form (@ (method "POST"))
(h2 "Log in")
(p (label "signin")
(input (@ (name "signin")
(type "text"))))
(p (label "password")
(input (@ (name "password")
(type "password"))))
(p (@ (class "form-control"))
(input (@ (type "submit")
(value "submit"))))))))
(define (signin/post request body)
...)
(define (maybe-error error)
(if error
`(p (@ (class "error")) ,error)
'()))
(sxml->response (signin/template '() '())))
(define (required value)
(and (or (not value)
(< (string-length (car value)) 1))
"this field is required."))
(define %signin-validator `(("username" . ,required)
("password" . ,required)))
(define (signin/form-validate form)
(validate %signin-validator form)) ;; shallow validation
(define (signin/signin app username password)
(let ((user (query-user-by-username username)))
(if user
(if (verify* (grf3:vertex-ref user 'user/hash)
password
(app-pepper app))
user
#f)
#f)))
(define (user-auth-token app user)
;; For privacy reasons, the user unique identifier (uid) is used to
;; build the authentication token. The user MUST be randomly
;; generated. Given a user's uid, it MUST NOT be possible to find
;; out the associated username. Otherwise said, this uid must appear
;; nowhere else, in particular it MUST NOT appear in urls.
(string-sign (grf3:vertex-uid user) (app-pepper app)))
(define (signin/post app request body)
(let ((form (decode body)))
(let ((errors (signin/form-validate form)))
(if (null? errors)
(let ((user (signin/signin app
(car (ref form "username"))
(car (ref form "password")))))
(if user
(let* ((token (user-auth-token app user))
(cookies `((token . ,token))))
(redirect "/" #:cookies cookies))
(sxml->response
(signin/template form `(("username" . "wrong username?")
("password" . "wrong password?"))))))
(sxml->response (signin/template form errors))))))
;;; signup
(define (signup/template values errors)
(template "signup"
`(form (@ (method "POST"))
(h2 "Sign up")
,(form/input "text"
"username"
"username"
(ref values "username")
(ref errors "username"))
,(form/input "password"
"password"
"password"
#f
(ref errors "password"))
,(form/input "password"
"confirmation"
"confirmation"
#f
(ref errors "confirmation"))
,(form/submit "submit"))))
(define (make-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 ((username-error (assoc-ref errors "username"))
(password-error (assoc-ref errors "password"))
(confirmation-error (assoc-ref errors "confirmation")))
(template "signup"
`(form (@ (method "POST"))
(h2 "Sign up")
(div (@ (class ,(make-class `(("form-item" . #t)
("error" . ,username-error)))))
(p (label "username")
(input (@ (name "username")
(type "text"))))
,(maybe-error username-error))
(div (@ (class ,(make-class `(("form-item" . #t)
("error" . ,password-error)))))
(p (label "password")
(input (@ (name "password")
(type "password")))))
(div (@ (class ,(make-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 '())))
(sxml->response (signup/template '() '())))
(define (username-valid? username)
(and (or (not username)
(eq? (string-length (car username)) 0))
"username must be at least one character"))
(< (string-length (car username)) 1))
"username must be at least one character."))
(define (password-valid? password)
(and (not password)
;; TODO: implement password strength
"password is required"))
(define (%char-set-predicate char-set)
(lambda (char)
(char-set-contains? char-set char)))
(define %signup `(("username" . ,username-valid?)
("password" . ,password-valid?)))
(define (char-set-predicate char-set)
(lambda (lst)
(any values (map (%char-set-predicate char-set) lst))))
(define (signup/post request body)
(define digit? (char-set-predicate char-set:digit))
(define lower? (char-set-predicate char-set:lower-case))
(define upper? (char-set-predicate char-set:upper-case))
(define other? (char-set-predicate (char-set-difference char-set:full
char-set:letter+digit)))
(define %strong-predicates (list digit? lower? upper? other?))
(define (strong-predicate password)
(lambda (predicate)
(predicate password)))
(define (strong? password)
(and
(<= 8 (string-length password))
(every values (map (strong-predicate (string->list password)) %strong-predicates))))
(define (password-valid? password)
(and (or (not password)
(not (strong? (car password))))
"password must be at least eight characters including lower case, upper case, digit and punctuation."))
(define (confirmation-valid? confirmation)
(and (or (not confirmation)
(not (strong? (car confirmation))))
"confirmation must be the same as password."))
(define %signup-validator `(("username" . ,username-valid?)
("password" . ,password-valid?)
("confirmation" . ,confirmation-valid?)))
(define (validate-passwords-match form)
(if (string=? (car (ref form "password")) (car (ref form "confirmation")))
'()
`(("confirmation" . "confirmation must be the same as password."))))
(define (validate-username-available form)
(if (query-user-by-username (car (ref form "username")))
`(("username" . "username already taken."))
'()))
(define (signup/form-validate form)
(let ((errors (validate %signup-validator form))) ;; shallow validation
(if (null? errors)
(append (validate-passwords-match form) ;; deep validation
(validate-username-available form))
errors)))
(define (query-single-user?)
(eq? (length (fs:find 'type 'user)) 1))
(define (app-init user)
"Initialize the application with USER as superuser. Return the app
vertex."
(grf3:save (grf3:vertex-set user 'user/superuser #t))
(let* ((username (grf3:vertex-ref user 'user/username))
(app/name (string-append username "'s culturia")))
(grf3:save (grf3:create-vertex `((type . app)
(app/name . ,app/name)
(app/tagline . "my place in the cyberspace"))))))
(define (signup/signup app username password)
"Create an user with USERNAME and PASSWORD. Create app vertex if
it's the first user and set the created user as superuser. Return the
user vertex"
(let ((hash (hash-secret password (app-pepper app))))
(let ((user (grf3:save (grf3:create-vertex `((type . user)
(user/username . ,username)
(user/hash . ,hash))))))
(when (query-single-user?)
(log-info "First signup, initialize the application")
(app-init user))
user)))
(define (signup/post app request body)
(let ((form (decode body)))
(let ((errors (validate %signup form)))
;; TODO: implement deep validation
(let ((errors (signup/form-validate form)))
(if (null? errors)
(redirect "/")
(sxml->response (signup/template errors))))))
(define (handler request body)
(begin
(signup/signup app
(car (ref form "username"))
(car (ref form "password")))
(redirect "/signin"))
(sxml->response (signup/template form errors))))))
(define (handler app request body)
(log-debug "~a ~a" (request-method request) (uri-path (request-uri request)))
(with-context*
;; TODO: only do it in debug mode
(and=> (request-user request app)
(lambda (user)
(log-debug "user is ~s" (grf3:vertex-ref user 'user/username))))
(match (cons (request-method request) (request-path-components request))
('(GET) (index request))
('(GET) (index app request))
('(GET "signin") (signin/get request))
('(POST "signin") (signin/post request post))
('(POST "signin") (signin/post app request body))
('(GET "signup") (signup/get request))
('(POST "signup") (signup/post request body))
('(POST "signup") (signup/post app 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")
(with-env (env-open* "wt" (list *feature-space*) "create,log=(enabled=true)")
(run-server handler)))
(let ((app (make-app "super-secret-string"))) ;; TODO: make it a fluid
(with-env (env-open* "wt" (list *feature-space*) "create,log=(enabled=true)")
(run-server (lambda (request body) (handler app request body))))))
......@@ -15,12 +15,12 @@
(define-module (web helpers))
;; stdlib
(use-modules (web request))
(use-modules (web response))
(use-modules (web uri))
(use-modules ((web request)))
(use-modules ((web response)))
(use-modules ((web uri)))
;; local
(use-modules (web html))
(use-modules ((web html)))
;;; helpers
......@@ -30,7 +30,8 @@
example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
(split-and-decode-uri-path (uri-path (request-uri request))))
(define-public (render-html sxml)
(define-public (sxml->response sxml)
(values '((content-type . (text/html)))
(lambda (port)
(sxml->html sxml port))))
......@@ -43,8 +44,40 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
(values (build-response #:code 404)
(string-append "Resource not found: " uri)))
(define-public (redirect uri)
(values (build-response #:code 303 #:headers `((Location . ,uri))) ""))
(define (make-set-cookie-header pair) ;; XXX: https://mdn.io/Set-Cookie,
(let ((key (car pair))
(value (cdr pair)))
;; The cookie will have the lifetime of a session cookie.
`(Set-Cookie . ,(string-append (symbol->string key)
"= "
value
"; HttpOnly"
"; SameSite=Strict"))))
(define (alist->set-cookie-headers alist)
(let loop ((alist alist)
(out '()))
(if (null? alist)
out
(loop (cdr alist) (cons (make-set-cookie-header (car alist)) out)))))
(define-public redirect
(lambda* (uri #:key cookies)
(if cookies
(let ((headers (append `((Location . ,uri))
(alist->set-cookie-headers cookies))))
(values (build-response #:code 303 #:headers headers) ""))
(values (build-response #:code 303 #:headers `((Location . ,uri))) ""))))
(define-public (error)
(values (build-response #:code 500)))
(define (%make-cookie item)
(let ((item* (string-split item #\=)))
(cons (string->symbol (car item*)) (cadr item*))))
(define-public (request-cookies request)
(let ((headers (request-headers request)))
(and=> (assq-ref headers 'cookie)
(lambda (cookie)
(map %make-cookie (map string-trim (string-split cookie #\;)))))))
......@@ -131,3 +131,8 @@ list ATTRS and the child nodes in BODY."
(obj (object->escaped-html obj port))))
(export sxml->html)
(define-syntax-rule (sxml/maybe value)
(if value value '()))
(export sxml/maybe)
......@@ -17,6 +17,7 @@
(_ (->string value))))
(define-public (make-style alist)
"Create style from an ALIST"
(let loop ((alist alist)
(out ""))
(if (null? alist)
......@@ -27,3 +28,13 @@
(symbol->string (caar alist))
": "
(make-value (cdar alist)))))))
(define-public (make-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)))))