cookie.scm (3693B)
1 ;;; guile-webutils -- Web application utilities for Guile 2 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org> 3 (define-module (cookie) 4 #:export (set-cookie delete-cookie)) 5 (use-modules (srfi srfi-1) 6 (srfi srfi-19) 7 (srfi srfi-26) 8 (ice-9 control) 9 (ice-9 match) 10 (web http)) 11 12 (define cookie-val-char-set 13 (char-set-difference (char-set-delete char-set:ascii #\, #\;) 14 char-set:iso-control)) 15 16 (define cookie-name-char-set 17 (char-set-delete cookie-val-char-set #\=)) 18 19 (define (parse-cookie cookie-text) 20 (let ((parts (string-split cookie-text #\;))) 21 (define (split-cookie-pair cookie-pair) 22 (let* ((trimmed (string-trim cookie-pair)) 23 (delim (string-index trimmed #\=)) 24 (attrib (if delim 25 (substring trimmed 0 delim) 26 trimmed)) 27 (val (if delim 28 (substring trimmed (+ delim 1)) 29 #t))) 30 (cons attrib val))) 31 (map split-cookie-pair parts))) 32 33 (define (date->http-date-string date) 34 (call-with-output-string (cut (@@ (web http) write-date) date <>))) 35 36 (define (write-cookie cookie-alist port) 37 (let ((cookie-str 38 (string-join 39 (map (match-lambda 40 ((name . (? string? val)) 41 (string-append name "=" val)) 42 ((name . (? date? val)) 43 (string-append name "=" (date->http-date-string val))) 44 ((name . #t) 45 name)) 46 cookie-alist) 47 "; "))) 48 (display cookie-str port))) 49 50 (define (valid-cookie-name? str) 51 (and (string? str) 52 (string-every cookie-name-char-set str))) 53 54 (define (valid-cookie-val? str) 55 (or (eq? str #t) 56 (and (string? str) 57 (string-every cookie-val-char-set str)) 58 (date? str))) 59 60 (define (validate-cookie cookie-alist) 61 (match cookie-alist 62 ((((? valid-cookie-name? name) . (or #t (? valid-cookie-val? _))) ...) 63 #t) 64 (_ #f))) 65 66 (declare-header! "Cookie" 67 parse-cookie validate-cookie write-cookie) 68 69 (define (parse-set-cookie str) 70 (match (parse-cookie str) 71 (((name . val) attrs ...) 72 (list name val attrs)))) 73 74 (define (validate-set-cookie obj) 75 (match obj 76 ((name val (attrs ...)) 77 (validate-cookie 78 (cons (cons name val) 79 attrs))) 80 (_ #f))) 81 82 (define (write-set-cookie obj port) 83 (match obj 84 ((name val (attrs ...)) 85 (write-cookie 86 (cons (cons name val) 87 attrs) 88 port)))) 89 90 (declare-header! "Set-Cookie" 91 parse-set-cookie validate-set-cookie write-set-cookie 92 #:multiple? #t) 93 94 (define* (set-cookie name #:optional (val "") 95 #:key expires max-age domain 96 path secure http-only 97 (extensions '())) 98 (define (maybe-append name val) 99 (lambda (prev) 100 (if val 101 (cons (cons name val) 102 prev) 103 prev))) 104 (define basic-prop-alist 105 ((compose 106 (maybe-append "Expires" expires) 107 (maybe-append "Max-Age" max-age) 108 (maybe-append "Domain" domain) 109 (maybe-append "Path" path) 110 (maybe-append "Secure" secure) 111 (maybe-append "HttpOnly" http-only)) 112 '())) 113 (define prop-alist 114 (append basic-prop-alist 115 extensions)) 116 (cons 'set-cookie (list name val prop-alist))) 117 118 (define %the-epoch 119 (time-monotonic->date (make-time 'time-monotonic 0 0) 0)) 120 121 (define (delete-cookie name) 122 (set-cookie name 123 #:expires %the-epoch 124 #:path "/" 125 #:secure #t 126 #:http-only #t))