...
 
Commits (16)
  • cosmit · 7e2bcb49
    amirouche authored
  • typofix · 57b30c27
    amirouche authored
  • typofix · 5b777d43
    amirouche authored
  • argon2: update to 0~20161029-1 (ubuntu 17.10) · 54d99366
    - 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
    amirouche authored
  • .dir-locals.el: add template · 394b91d8
    amirouche authored
  • html: add sxml/maybe · d3b37dd0
    amirouche authored
  • .gitignore: add src/wt/ · 3dc9b3ef
    amirouche authored
  • style: move make-class · d543c835
    amirouche authored
  • doc++ · 4032aadd
    amirouche authored
  • cosmit · d0117e8d
    amirouche authored
  • cosmit · 7600ba94
    amirouche authored
  • css: rename form-item to form-field · 3153de2b
    amirouche authored
  • helpers: rename render-html to sxml->response · 0fdb05b8
    amirouche authored
  • helpers: add cookies helpers. · cbe0db05
    - 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.
    amirouche authored
  • complete sign up and sign in paths · a2599b01
    - 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.
    amirouche authored
......@@ -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;
......
......@@ -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)))))