diff options
Diffstat (limited to 'module')
68 files changed, 7478 insertions, 853 deletions
diff --git a/module/calp.scm b/module/calp.scm index 81268cbb..b1952547 100644 --- a/module/calp.scm +++ b/module/calp.scm @@ -1,4 +1,9 @@ -(define-module (calp)) +(define-module (calp) + :export (version prodid)) ;; Update me on new release -(define-public version "0.6.1") +(define version "0.6.1") + +(define (prodid) + (format #f "-//hugo//calp ~a//EN" + (@ (calp) version))) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index a240d00c..070d1c3f 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -171,7 +171,7 @@ window.default_calendar='~a';" ;; Button to view week (G_ "Week")) - ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html") + ,(btn href: (date->string (day start-date 1) "/month/~1.html") ;; button to view month (G_ "Month")) @@ -381,13 +381,11 @@ window.default_calendar='~a';" (repeating% regular (partition repeating? flat-events)) (repeating (for ev in repeating% - (define instance (copy-vcomponent ev)) - - (set! (prop instance 'UID) (output-uid instance)) - (delete-parameter! (prop* instance 'DTSTART) '-X-HNH-ORIGINAL) - (delete-parameter! (prop* instance 'DTEND) '-X-HNH-ORIGINAL) - - instance))) + ;; TODO + (-> (set-properties ev 'UID (output-uid ev)) + ;; (focus (prop* instance 'DTSTART) (lambda (vline) (remove-parameter vline key))) + ;; (focus (prop* instance 'DTEND) (lambda (vline) (remove-parameter vline key))) + )))) `( ;; Mapping showing which events belongs to which calendar, diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index 7b991104..e400c1ba 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -31,6 +31,8 @@ (body (a (@ (href ("/today"))) ,(G_ "Show today")) (h2 ,(G_ "Search term")) + ;; TODO add blurb documenting available variables here, + ;; and link to full documentation page (form (pre (textarea (@ (name "q") (rows 5) (spellcheck false) (style "width:100%")) diff --git a/module/calp/namespaces.scm b/module/calp/namespaces.scm new file mode 100644 index 00000000..09a642da --- /dev/null +++ b/module/calp/namespaces.scm @@ -0,0 +1,14 @@ +(define-module (calp namespaces)) + +;;; Commentary: +;;; (XML) Namespaces used by different parts of the program. +;;; Code: + +(define-public webdav (string->symbol "DAV:")) +(define-public caldav (string->symbol "urn:ietf:params:xml:ns:caldav")) +(define-public xcal (string->symbol "urn:ietf:params:xml:ns:icalendar-2.0")) + +(define-public namespaces + `((d . ,webdav) + (c . ,caldav) + (x . ,xcal))) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index b4901900..3383f7a6 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -294,11 +294,11 @@ str))))) (return '((content-type application/xml)) - (with-output-to-string - (lambda () - (sxml->xml - `(properties - (uid (text ,(prop event 'UID))))))))))) + (lambda (port) + (sxml->xml + `(properties + (uid (text ,(prop event 'UID)))) + port)))))) ;; Get specific page by query string instead of by path. ;; Useful for <form>'s, since they always submit in this form, but also @@ -332,16 +332,16 @@ (GET "/calendar/:uid{.*}.xcs" (uid) (aif (get-event-by-uid global-event-object uid) (return '((content-type application/calendar+xml)) - ;; TODO sxml->xml takes a port, would be better - ;; to give it the return port imidiately. - (with-output-to-string - ;; TODO this is just the vevent part. - ;; A surounding vcalendar is required, as well as - ;; a doctype. - ;; Look into changing how events carry around their - ;; parent information, possibly splitting "source parent" - ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) it))))) + ;; TODO this is just the vevent part. + ;; A surounding vcalendar is required, as well as + ;; a doctype. + ;; Look into changing how events carry around their + ;; parent information, possibly splitting "source parent" + ;; and "program parent" into different fields. + (lambda (port) + (sxml->xml + ((@ (vcomponent formats xcal output) vcomponent->sxcal) it) + port))) (return (build-response code: 404) (format #f (G_ "No component with UID=~a found.") uid)))) @@ -414,13 +414,13 @@ (format #f "~?~%" fmt arg)))))) (return `((content-type ,(content-type html))) - (with-output-to-string - (lambda () - ((sxml->output html) - (search-result-page - error - (and=> q (negate string-null?)) - search-term search-result page paginator)))))) + (lambda (port) + ((sxml->output html) + (search-result-page + error + (and=> q (negate string-null?)) + search-term search-result page paginator) + port)))) ;; NOTE this only handles files with extensions. Limited, but since this ;; is mostly for development, and something like nginx should be used in diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index f2d58337..4c5a0886 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -4,28 +4,13 @@ :use-module ((calp server routes) :select (make-make-routes)) :use-module (ice-9 threads) :use-module (srfi srfi-88) + :use-module (calp server socket) :export (start-server)) +;;; TODO Do I really want this hardcoded here? (define handler (make-make-routes)) -;; NOTE The default make-default-socket is broken for IPv6. -;; A patch has been submitted to the mailing list. 2020-03-31 -;; -;; This sets up the socket manually, and sends that to @code{http-open}. -(define* (make-default-socket/fixed family addr port) - (let ((sock (socket family SOCK_STREAM 0))) - (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - (bind sock family addr port) - sock)) - -(define* (setup-socket key: - (host #f) - (family AF_INET) - (addr (if host (inet-pton family host) - INADDR_LOOPBACK)) - (port 8080)) - (make-default-socket/fixed family addr port)) (define (start-server open-params) (run-server handler diff --git a/module/calp/server/socket.scm b/module/calp/server/socket.scm new file mode 100644 index 00000000..990adfa6 --- /dev/null +++ b/module/calp/server/socket.scm @@ -0,0 +1,48 @@ +(define-module (calp server socket) + :use-module (srfi srfi-88) + :use-module (web server) + :export (setup-socket + run-at-any-port) + ) + +;; NOTE The default make-default-socket is broken for IPv6. +;; A patch has been submitted to the mailing list. 2020-03-31 +;; +;; This sets up the socket manually, and sends that to @code{http-open}. +(define* (make-default-socket/fixed family addr port) + (let ((sock (socket family SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock)) + +(define* (setup-socket key: + (host #f) + (family AF_INET) + (addr (if host (inet-pton family host) + INADDR_LOOPBACK)) + (port 8080)) + (make-default-socket/fixed family addr port)) + + +(define* (run-at-any-port handler key: + (min-port 8081) + msg-port) + (unless msg-port + (scm-error 'misc-error "run-at-any-port" + "msg-port required" + '() #f)) + (let loop ((port min-port)) + (catch 'system-error + (lambda () + (let ((socket (setup-socket port: port))) + (let ((addr (format #f "http://localhost:~a~%" port))) + (display addr msg-port) + (force-output msg-port) + (format #t "Server started at ~s~%" addr) + (run-server handler 'http + `(socket: ,socket)) + (format #t "Server closed~%")))) + (lambda (err proc fmt args data) + (if (= EADDRINUSE (car data)) + (loop (1+ port)) + (apply throw err proc fmt args data)))))) diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm new file mode 100644 index 00000000..781a85d9 --- /dev/null +++ b/module/calp/server/webdav.scm @@ -0,0 +1,768 @@ +(define-module (calp server webdav) + :use-module ((hnh util) :select (for group -> ->> init+last catch*)) + :use-module (ice-9 match) + :use-module (ice-9 regex) + :use-module (ice-9 format) + :use-module (ice-9 control) + :use-module (web request) + :use-module (web response) + :use-module (web uri) + :use-module (web server) + :use-module ((web http) :select (declare-method! + declare-header!)) + :use-module (web http status-codes) + :use-module (datetime) + :use-module (sxml match) + :use-module (sxml namespaced) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module (calp namespaces) + :use-module (calp webdav resource) + :use-module (calp webdav resource virtual) + :use-module (calp webdav resource file) + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module (calp webdav proppatch) + :use-module (oop goops) + :export (; run-run + run-propfind + run-proppatch + run-options + run-get + run-put + run-delete + run-mkcol + run-copy + run-move + run-report + + root-resource + webdav-handler + )) + +;; (define* (my-build-response . kvs) +;; (define dt (datetime->string (current-datetime) "~a, ~d ~b ~Y ~H:~M:~S GMT")) +;; (define server (format #f "calp/~a" (@ (calp) version))) +;; (let ((as (kvlist->assq kvs))) +;; (append kvs +;; (list +;; reason-phrase: (http-status-phrase (assq-ref as code:)) +;; headers: (append (or (assq-ref kvs headers:) '()) +;; (list +;; server: server +;; date: dt +;; connection: 'keep-alive)))))) + +(define (swap p) + (xcons (car p) (cdr p))) + + +(define output-namespaces + (map (lambda (pair) (call-with-values (lambda () (car+cdr pair)) + xcons)) + namespaces)) + +;; (define (run-filter context filter-spec) +;; (sxml-match filter-spec +;; [(c:comp-filter (@ (name ,name)) . ,rest) +;; ;; TODO +;; (filter (lambda (child) (string=? name (type child))) +;; (children context))] +;; [(c:prop-filter (@ (name ,name))) +;; (prop context name) +;; ] +;; [(c:prop-filter (@ (name ,name)) . ,rest) +;; ] +;; [(c:param-filter (@ (name ,name)) . ,rest)] +;; [(c:is-not-defined)] +;; [(c:text-match (@ . ,attrs) . ,data)] +;; [(c:time-range (@ . ,attrs))])) + + + +;; Requests can content-type be both both application/xml and text/xml, server MUST accept both (RFC 4918 8.2) + +;; ;; RFC 4918 8.2 +;; (catch 'parser-error +;; (lambda () (xml->sxml body)) +;; (lambda (err input-port . msg) +;; (define err-msg +;; (with-output-to-string +;; (lambda () (for-each display msg)))) +;; (return (build-response code: 400 +;; headers: ((content-type . (text/plain)))) +;; err-msg))) + +;; ;; If a body is sent by the client when not expected, the server MUST repspond +;; ;; with 415 (RFC 4918 8.4) + +;; PROPPATCH +;; SHOULD support setting of arbitrary dead properties (RFC4918 9.2) +;; Fruux supports this +;; NOTE this means that user quotas must include dead properties + + +;; A caldav server MUST support +;; - RFC4918 (WebDAV) Class 1 +;; - RFC3744 WebDAV ACL including additional privilege defined in 6.1 +;; - HTTPS +;; - ETags from RFC2616 (http) + +;; MKCALENDAR NOT required + + + + +;; getcontentlanguage, "dead" property + +(declare-method! "PROPFIND" 'PROPFIND) +(declare-method! "PROPPATCH" 'PROPPATCH) +(declare-method! "MKCOL" 'MKCOL) +(declare-method! "COPY" 'COPY) +(declare-method! "MOVE" 'MOVE) +(declare-method! "LOCK" 'LOCK) +(declare-method! "UNLOCK" 'UNLOCK) +(declare-method! "REPORT" 'REPORT) +(declare-method! "MKCALENDAR" 'REPORT) + + + +(define (root-element sxml) + (sxml-match sxml + [(*TOP* (*PI* . ,args) ,root) root] + [(*TOP* ,root) root] + [,root root])) + +(define (root-element/namespaced sxml) + (cond ((not (list? sxml)) (scm-error 'misc-error "root-element/namespaced" + "Argument is invalid sxml: ~s" + (list sxml) #f)) + ((null? (car sxml)) (scm-error 'misc-error "root-element/namespaced" + "No root in an empty list" + '() #f)) + ((eq? '*TOP* (car sxml)) + (let ((children (cdr sxml))) + (cond ((null? children) #f) + ((pi-element? (car children)) + (cadr children)) + (else (car children))))) + (else sxml))) + + +(define root-resource (make-parameter #f)) + + + +(define (parse-dav-line str) + (map (lambda (item) + (cond ((string-match "^[0-9]+$" item) + => (lambda (m) (number->string (match:substring m)))) + ((string-match "^<(.*)>$" item) + => (lambda (m) (string->uri (match:substring m 1)))) + (else (string->symbol item)))) + (map string-trim-both (string-split str #\,)))) + +(define (validate-dav-line lst) + (every (lambda (item) + (or (and (number? item) (<= 1 item 3)) + (uri? item) + ;; Possibly check against list of valid tokens + (symbol? item))) + lst)) + +(define (write-dav-line lst port) + (display + (string-join (map (lambda (item) + (cond ((number? item) (number->string item)) + ((uri? item) (string-append "<" (uri->string item) ">")) + (else (symbol->string item)))) + lst) + ", " 'infix) + port)) + +(declare-header! "DAV" + parse-dav-line + validate-dav-line + write-dav-line) + +(declare-header! "Depth" + (lambda (str) + (if (string-ci=? str "Infinity") + 'infinity + (string->number str))) + (lambda (value) + (memv value '(0 1 infinity))) + (lambda (value port) + (display value port))) + +(declare-header! "Destination" + string->uri + uri? + (lambda (uri port) + (display (uri->string uri) port))) + +;;; TODO +;; (declare-header! "If") + +;;; TODO +;; (declare-header! "Lock-Token") + +(declare-header! "Overwrite" + (lambda (str) + ;; TODO assert isn't a thing + ;; (assert (= 1 (string-length str))) + (case (string-ref str 0) + ((#\F) #f) + ((#\T) #t) + (else (throw 'error)))) + boolean? + (lambda (b port) + (display (if b "T" "F") + port))) + +;;; TODO +;; (declare-header! "Timeout") + + + +(define (run-propfind href request body) + (define headers (request-headers request)) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + (define requested-resources + (case (or (assoc-ref headers 'depth) 'infinity) + ((0) (list (cons href resource))) + ((1) (cons (cons href resource) + (map (lambda (child) + (cons (append href (list (name child))) + child)) + (children resource)))) + ((infinity) (all-resources-under resource href)))) + + ;; Body, if it exists, MUST have be a DAV::propfind object + (define property-request + (cond ((string? body) + (xml->namespaced-sxml body)) + ((bytevector? body) + (-> body + (bytevector->string + (make-transcoder (utf-8-codec))) + xml->namespaced-sxml)) + (else `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)))))) + + + (catch 'bad-request + (lambda () + (values (build-response + code: 207 + reason-phrase: (http-status-phrase 207) + headers: '((content-type . (application/xml)))) + (lambda (port) + (namespaced-sxml->xml + `(,(xml webdav 'multistatus) + ,@(for (href . resource) in requested-resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (parse-propfind (root-element/namespaced property-request) + resource))))) + namespaces: output-namespaces + port: port) + (newline port)))) + (lambda (err proc fmt args data) + (values (build-response + code: 400 + headers: '((content-type . (text/plain)))) + (lambda (port) + (apply format port fmt args))))))) + (else (values (build-response code: 404) "")))) + + + +(define (run-proppatch href request body) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + ;; Body MUST exist, and be a DAV::propertyupdate element + (catch 'bad-request + (lambda () + (values (build-response + code: 207 + reason-phrase: (http-status-phrase 207) + headers: '((content-type . (application/xml)))) + (lambda (port) + (define-values (request namespaces*) + (cond ((string? body) + (-> body + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces + (map swap namespaces)))) + ((bytevector? body) + (-> body + (bytevector->string (make-transcoder (utf-8-codec))) + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces + (map swap namespaces)))) + (else (throw 'body-required)))) + + (namespaced-sxml->xml + `(,(xml webdav 'multistatus) + (,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (parse-propertyupdate + (root-element request) + (map swap namespaces*) + resource)))) + port: port)))) + (lambda (err proc fmt args data) + (values (build-response + code: 400 + headers: '((content-type . (text/plain)))) + (lambda (port) + (apply format port fmt args))))))) + (else (values (build-response code: 404) "")))) + + +(define (run-options href request) + (values + (build-response code: 200 + headers: `((dav . (1)) + ;; (DAV . "calendar-access") + ;; TODO collecting this set dynamically would be fancy! + (allow . (GET HEAD PUT + MKCOL PROPFIND OPTIONS + DELETE + COPY + MOVE + ;; LOCK + ;; UNLOCK + ;; REPORT + )))) + "")) + +(define (run-get href request mode) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + ;; "/calendar/:user/:calendar/:filename" + ;; headers: `((content-type ,content-type)) + (values (build-response code: 200) + (case mode + ((HEAD) "") + ((GET) (content resource)) + (else (scm-error 'misc-error "run-get" + "Unknown mode: ~s" + (list mode) #f)))))) + (else (values (build-response code: 404) "")))) + +(define (run-put href request request-body) + (cond ((null? href) + (values (build-response code: 405 headers: '((content-type . (text/plain)))) + "Can't PUT on root resource")) + ((lookup-resource (root-resource) (drop-right href 1)) + => (lambda (parent) + (cond ((lookup-resource parent (list (last href))) + => (lambda (child) + (if (is-collection? child) + (values (build-response code: 405) "") + (begin + (set-content! child request-body) + (values (build-response code: 204) ""))))) + (else + (add-resource! parent (last href) + request-body) + (values (build-response code: 201) ""))))) + ;; No parent collection, fail per [WEBDAV] 9.7.1. + (else (values (build-response code: 409))))) + +(define (run-mkcol href request _) + ;; TODO href="/" + (if (assoc-ref (request-headers request) 'content-type) + (values (build-response code: 415) + "") + (let ((path name (init+last href))) + (cond ((lookup-resource (root-resource) path) + => (lambda (parent) + (catch 'resource-exists + (lambda () + (add-collection! parent name) + (values (build-response code: 201) "")) + (lambda _ (values (build-response code: 405) ""))))) + (else + (values (build-response code: 409) "")))))) + + + +;;; TODO completely rewrite error handling here +;;; TODO what happens on copy between sub-trees of different types? +;;; Like from a <calendar-resource> tree to a <file-tree>. +(define (run-copy source-href request) + (define headers (request-headers request)) + (call/ec + (lambda (return) + (let* ((depth (or (assoc-ref headers 'depth) 'infinity)) + (destination-uri (assoc-ref headers 'destination)) + (dest-href (-> headers (assoc-ref 'destination) + uri-path string->href)) + (overwrite? + (cond ((assoc 'overwrite headers) => cdr) + (else #t)))) + + ;; (assert (memv depth '(0 infinity))) + ;; (unless (string=? (listen-uri) (uri-host destination-uri)) + ;; (throw 'cross-domain-copy-not-supported)) + + (let ((dest-path dest-name (init+last dest-href))) + (let ((source-resource + (cond ((lookup-resource (root-resource) source-href) => identity) + (else (return (build-response code: 404) "")))) + (destination-parent-resource + (cond ((lookup-resource (root-resource) dest-path) => identity) + (else (return (build-response + code: 409 + reason-phrase: (http-status-phrase 409) + headers: '((content-type . (text/plain)))) + "One or more parent components of destination are missing"))))) + + (case (copy-to-location! source-resource destination-parent-resource + new-name: dest-name + include-children?: (case depth + ((0) #f) + ((infinity) #t) + (else (throw 'invalid-requeqst))) + overwrite?: overwrite?) + ((created) + (values (build-response code: 201) "")) + ((replaced) + (values (build-response code: 204) "")) + ((collision) + (values (build-response code: 412) ""))))))))) + + +(define (run-delete href request) + ;; TODO href="/" + (let ((path name (init+last href))) + (cond ((lookup-resource (root-resource) path) + => (lambda (parent) + (cond ((lookup-resource parent (list name)) + => (lambda (child) + (delete-child! parent child) + (values (build-response code: 202) + ""))) + (else + (values (build-response code: 404) ""))))) + (else + (values (build-response code: 404) ""))))) + + +(define (run-move href request) + ;; TODO href="/" + (define headers (request-headers request)) + (call/ec + (lambda (return) + (define-values (path name) (init+last href)) + (define parent (or (lookup-resource (root-resource) path) + (return (build-response code: 404) + "Source Parent not found"))) + (define child (or (lookup-resource parent (list name)) + (return (build-response code: 404) + "Source not found"))) + (define-values (dest-path dest-name) + (-> headers (assoc-ref 'destination) + uri-path string->href init+last)) + (define dest-parent (or (lookup-resource (root-resource) dest-path) + (return (build-response code: 404) + "Dest Parent not found"))) + (define overwrite? (cond ((assoc 'overwrite headers) => cdr) + (else #t))) + (define status (move-to-location! parent child + dest-parent + new-name: dest-name + overwrite?: overwrite?)) + + (case status + ((created) + (values (build-response code: 201) "")) + ((replaced) + (values (build-response code: 204) "")) + ((collision) + (values (build-response code: 412) "")))))) + + + +;; (define (run-report href request request-body)) + + + +(define log-table (make-parameter #f)) +(define (init-log-table!) (log-table '())) +(define (log-table-add! . args) + (for (key value) in (group args 2) + (log-table (acons key value (log-table))))) +(define* (log-table-get key optional: dflt) + (or (assoc-ref (log-table) key) + dflt)) + +(define (log-table-format . args) + (for-each (lambda (arg) + (cond ((string? arg) (display arg)) + ((symbol? arg) (cond ((log-table-get arg) + => display))) + ((pair? arg) (cond ((log-table-get (car arg)) + => (compose display (cdr arg))))) + (else #f))) + args)) + +(define (emit-log!) + ;; (write (log-table) (current-error-port)) + ;; (newline (current-error-port)) + (display + (with-output-to-string + (lambda () + (log-table-format (cons 'now (lambda (n) (datetime->string n "~H:~M:~S"))) + " " 'method " " + (cons 'uri uri->string) + " ") + (case (request-method (log-table-get 'request)) + ((COPY MOVE) (log-table-format + (cons 'headers (lambda (h) (and=> (assoc-ref h 'destination) uri->string))) + " ")) + (else "")) + ;; Nginx uses + ;; <ip> - - [<date>] "<request-line>" <request-status> <content-length> "<referer-url>" "<user-agent>" + (log-table-format 'response-code " " + 'response-phrase + " " + (cons 'headers (lambda (h) (assoc-ref h 'x-litmus))) + "\n") + + (cond ((log-table-get 'msg) + => (lambda (it) + (display it) + (newline)))))) + + (current-error-port)) + ) + + + + +;; For all headers: +;; `((server ,(format #f "calp/~a" (@ (calp) version))) +;; (date ,(datetime->string (current-datetime) +;; "~a, ~d ~b ~Y ~H:~M:~S GMT")) +;; (connection keep-alive)) + +;; Already fixed by server +;; (content-length ,(format #f (bytevector->length data))) + + +(define (webdav-handler request request-body) + (define href (-> request request-uri uri-path string->href)) + (init-log-table!) + (log-table-add! 'now (current-datetime) + 'method (request-method request) + 'uri (request-uri request) + 'headers (request-headers request) + 'request request) + + (catch* + (lambda () + ;; TODO also log result of execution + (call-with-values + (lambda () + (case (request-method request) + ((OPTIONS) (run-options href request)) + + ((PROPFIND) (run-propfind href request request-body)) + ((PROPPATCH) (run-proppatch href request request-body)) + + ((GET HEAD) (run-get href request (request-method request))) + + ((PUT) (run-put href request request-body)) + + ((DELETE) (run-delete href request)) + + ((MKCOL) (run-mkcol href request request-body)) + + ((COPY) (run-copy href request)) + ((MOVE) (run-move href request)) + + ;; ((REPORT)) + + (else (values (build-response code: 400) "")))) + (lambda (head body) + (log-table-add! + 'response head + 'response-code (response-code head) + 'response-phrase (response-reason-phrase head)) + (emit-log!) + (values head body)))) + + (parser-error + (lambda (err port msg . args) + (define head (build-response code: 400 + headers: '((content-type . (text/plain))))) + (define errmsg + (with-output-to-string + (lambda () + (display msg) + (for-each display args)))) + (log-table-add! 'response head + 'response-code 400 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + + (#t + (case-lambda ((err proc fmt args data) + (let ((head (build-response + code: 500 + headers: '((content-type . (text/plain))))) + (errmsg (if proc + (format #f "Error in ~a: ~?~%" proc fmt args) + (format #f "~?~%" fmt args)))) + (log-table-add! 'response head + 'response-code 500 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + (err + (let ((errmsg (format #f "General error: ~s~%" err))) + (log-table-add! 'response-code 500 + 'msg errmsg) + (emit-log!) + (values (build-response code: 500) + errmsg))))))) + + + +;;; TODO shouldn't this default to #f +(root-resource + (let () + (define root-resource (make <virtual-resource> name: "*root*")) + + (define virtual-resource (make <virtual-resource> + name: "virtual" + content: (string->bytevector "Hello, World\n" (native-transcoder)))) + + (define file-tree (make <file-resource> + root: "/home/hugo/tmp" + name: "files")) + + (mount-resource! root-resource file-tree) + (mount-resource! root-resource virtual-resource) + root-resource)) + + +(define (run-run) + (unless (root-resource) + (throw 'misc-error "run-run" + "root-resource parameter must be set before running" + (list) #f)) + (run-server webdav-handler + 'http + `(#:port 8102))) + +;; "/principals/uid/:uid" + +#; + +(define (make-make-routes) + (make-routes + + + ;; A file extension could be added, but + ;; text/calendar ⇒ .ics + ;; application/calendar+xml ⇒ .xcs + ;; application/calendar+json ⇒ UNKNOWN + (GET "/caldav/:user/:calendar/:filename" (user calendar filename) + (define requested-types + (cond ((assoc-ref r:headers 'accept) + => (lambda (accept) + (sort* accept < + (lambda (type) + (or (assoc-ref (cdr type) 'q) + 1000))))) + (else '(text/calendar)))) + (define available-types + '(text/calendar application/calendar+xml)) + + (define content-type (find (lambda (type) (memv type available-types)) requested-types)) + (define serializer + (case content-type + ((text/calendar) ical:serialize) + ((application/calendar+xml) xcal:serialize) + ((application/calendar+sexp) sxcal:serialize) + (else (return (build-response code: 415) + "Bad content type")))) + + (define event + (copy-as-orphan + (get-by-uid (get-store-by-name calendar) filename))) + + ;; TODO where is the event split into multiple VEVENT objects in the + ;; serialized form? Should be in the serializer, right? + + (define component + (vcalendar prodid: ((@ (calp) prodid)) + version: "2.0" + (list event))) + + (values `((content-type ,content-type)) + (call-with-output-string + (lambda (p) (serializer component p))))) + + (PUT "/caldav/:user/:calendar/:filename" (user calendar filename) + ;; Request Headers: + ;; If-None-Match + ;; Content-Type: text/calendar + ;; application/calendar+xml + + ;; TODO change -X-HNH to X-HNH-PRIVATE, see RFC4791 5.3.3 + + (define component + (let ((type args (car+cdr (assoc-ref r:headers 'content-type)))) + ;; Valid args: charset component optinfo + ;; Invalid args: method (see RFC4791 4.1) + ;; Component is for redundancy? + ;; optinfo is implementation dependant? + ;; Charset already handled by HTTP server + (case type + ((text/calendar) (ical:deserialize body)) + ((application/calendar+xml) (xcal:deserialize body)) + (else (return (build-response code: 415) + "Can't handle that content type"))))) + + (unless (eq? 'VCALENDAR (type component)) + ;; Top level object must be a VCALENDAR + ) + + ;; Must all children be VEVENT? + (children component) + + ;; All VEVENT component must be the the same event, so they should be merged into a single event + (define event (handle-events component)) + + ;; RFC4791 5.3.2: + ;; > The URL for each calendar object resource is entirely arbitrary and + ;; > does not need to bear a specific relationship to the calendar object + ;; > resource's iCalendar properties or other metadata. New calendar + ;; But requiring that UID and filename match makes things easier for us, at least for now + (unless (string=? filename (prop component 'UID)) + (return (build-response code: 400) + "UID and filename must match")) + + (let ((cal (get-calendar-by-name global-event-object calendar))) + ;; (add-and-save-event global-event-object cal component) + + (reparent! cal event) + (queue-write (get-store-for-calendar cal) event) + + ) + + ) + )) diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index 04effd68..316421eb 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -162,11 +162,11 @@ (date->string start)))) (format #t "\x1b[1m~a:\x1b[m ~a~%~%" (G_ "End") - (let ((start (prop ev 'DTSTART))) - (if (datetime? start) - (datetime->string (prop ev 'DTSTART) + (let ((end (prop ev 'DTEND))) + (if (datetime? end) + (datetime->string (prop ev 'DTEND) (G_ "~Y-~m-~d ~H:~M:~S")) - (date->string start)))) + (date->string end)))) (format #t "~a~%" (unlines (take-to (flow-text (or (prop ev 'DESCRIPTION) "") width: (min 70 width)) @@ -290,6 +290,7 @@ ">"))) (newline)) +;;; TODO what is this view? (define-method (input (this <view>) char) (case char ((#\j #\J down) (unless (= (active-element this) (1- (page-length this))) @@ -300,6 +301,9 @@ ((#\g) (set! (active-element this) 0)) ((#\G) (set! (active-element this) (1- (page-length this)))) + ;; TODO Launch edit mode! + ;; TODO should edit mode be here? + ((#\e) 'NOOP) ((#\q) '(pop))) diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm new file mode 100644 index 00000000..092d270a --- /dev/null +++ b/module/calp/webdav/property.scm @@ -0,0 +1,91 @@ +(define-module (calp webdav property) + :use-module (sxml namespaced) + :use-module (web http status-codes) + :use-module ((srfi srfi-1) :select (concatenate find)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util) + :use-module (calp namespaces) + :export (make-propstat + propstat? + propstat-status-code + propstat-property + propstat-error + propstat-response-description + + propstat + + merge-propstats + propstat-200? + ;; propstat->sxml + propstat->namespaced-sxml + )) + +;;; Commentary: +;;; Code: + + +;; Maps directly to [WEBDAV]'s propstat objects. This is just a simpler interface in the code. + +(define-record-type <propstat> + (make-propstat status prop error responsedescription) + propstat? + ;; An http status code indicating if this property is present + (status propstat-status-code) + ;; A list of namespaced sxml elements, such that they could all be + ;; directly inserted as the children of <DAV::prop/> + ;; @example + ;; `((,(xml ns tag) "Content")) + ;; @end example + (prop propstat-property) + + ;; See [WEBCAL] propstat XML element + (error propstat-error) + (responsedescription propstat-response-description)) + +(define* (propstat code prop key: error responsedescription) + (make-propstat code prop error responsedescription)) + +;; Query a given dead property from the given resource +;; property should be a xml-element item +;; (define (propfind-selected-property resource property) +;; (cond ((get-dead-property resource property) +;; => (lambda (it) (propstat 200 (list it)))) +;; (else (propstat 404 (list (list property)))))) +;; Takes a list of <propstat> items, finds all where status, error, and +;; responsedescription are all equal, and merges the prop tags of all those. +;; Returns a new list of <propstat> items +(define (merge-propstats propstats) + (map (lambda (group) + (define-values (code error desc) (unlist (car group))) + (make-propstat code + (concatenate + (map propstat-property (cdr group))) + error desc)) + (group-by (lambda (propstat) + (list (propstat-status-code propstat) + (propstat-error propstat ) + (propstat-response-description propstat))) + propstats))) + +(define (propstat-200? prop) + (= 200 (propstat-status-code prop))) + + +;; (define (propstat->sxml propstat) +;; `(d:propstat (d:prop ,(propstat-property propstat)) +;; (d:status ,(http-status-line (propstat-status-code propstat))) +;; ,@(awhen (propstat-error propstat) +;; `((d:error ,it))) +;; ,@(awhen (propstat-response-description propstat) +;; `((d:responsedescription ,it))))) + +(define (propstat->namespaced-sxml propstat) + `(,(xml webdav 'propstat) + (,(xml webdav 'prop) ,@(propstat-property propstat)) + (,(xml webdav 'status) ,(http-status-line (propstat-status-code propstat))) + ,@(awhen (propstat-error propstat) + `((,(xml webdav 'error) ,it))) + ,@(awhen (propstat-response-description propstat) + `((,(xml webdav 'responsedescription) ,it))))) diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm new file mode 100644 index 00000000..83725825 --- /dev/null +++ b/module/calp/webdav/propfind.scm @@ -0,0 +1,99 @@ +(define-module (calp webdav propfind) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (calp namespaces) + :use-module (srfi srfi-1) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :export (propfind-selected-properties + propfind-all-live-properties + propfind-most-live-properties + propfind-all-dead-properties + + parse-propfind + )) + +;;; Commentary: +;;; Procedures for the WebDav PROPFIND method +;;; Code: + +;; Properties should be a list of xml-tag-elements +;; return a list of propstat elements +;; work for both dead and alive objects +(define (propfind-selected-properties resource properties) + (map (lambda (el) (get-property resource el)) + properties)) + + +;; (define-method (supported-properties (self <resource>)) +;; (map (lambda (v) (cons webdav v)) +;; `())) + +;; Returns a list of <propstat> objects. +(define (propfind-all-live-properties resource) + (map (lambda (p) ((cdr p) resource)) + (live-properties resource))) + +;; Returns a list of <propstat> objects. +;; The list being the live properties defined by [WEBDAV] +(define (propfind-most-live-properties resource) + (map (lambda (p) ((property-getter (cdr p)) resource)) + webdav-properties)) + +;; Returns a list of <propstat> objects. +;; All "dead" properties on resource. +(define (propfind-all-dead-properties resource) + (map (lambda (v) (propstat 200 (list v))) + (dead-properties resource))) + + + + + +(define (find-element target list) + (define target* (xml-element-hash-key target)) + (find (lambda (x) (and (list? x) + (not (null? x)) + (xml-element? (car x)) + (equal? target* (xml-element-hash-key (car x))))) + list)) + +;; Takes a propfind xml element (tree), and a webdav resource object. +;; Returns a list of <propstat> objects. +(define (parse-propfind sxml resource) + ;; (assert (list? sxml)) + ;; (assert (not (null? sxml))) + ;; (assert eq? 'd:propfid (car sxml)) + (let ((propname (find-element (xml webdav 'propname) (cdr sxml))) + (allprop (find-element (xml webdav 'allprop) (cdr sxml))) + (include (find-element (xml webdav 'include) (cdr sxml))) + (prop (find-element (xml webdav 'prop) (cdr sxml)))) + (merge-propstats + (cond ((and allprop include) + ;; Return "all" properties + those noted by <include/> + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource) + (propfind-selected-properties + resource + (map car (cdr include))))) + (allprop + ;; Return "all" properties + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + ;; Return the list of available properties + (list (propstat + 200 + ;; car to get tagname, list to construct a valid xml element + (map (compose list car) + (append + (dead-properties resource) + (live-properties resource)))))) + (prop + ;; Return the properties listed + (propfind-selected-properties + resource + (map car (cdr prop)))) + (else + (scm-error 'bad-request "parse-propfind" + "Invalid search query ~s" (list sxml) (list sxml))))))) diff --git a/module/calp/webdav/proppatch.scm b/module/calp/webdav/proppatch.scm new file mode 100644 index 00000000..db7f5f95 --- /dev/null +++ b/module/calp/webdav/proppatch.scm @@ -0,0 +1,67 @@ +(define-module (calp webdav proppatch) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (sxml match) + :use-module (sxml namespaced) + :use-module ((hnh util) :select (for)) + :export (parse-propertyupdate) + ) + + +(define (parse-propertyupdate body namespaces resource) + (merge-propstats + (sxml-match body + [(d:propertyupdate . ,changes) + (define continuations + (concatenate + (for change in changes + (sxml-match change + [(d:remove (d:prop . ,properties)) + (map (lambda (prop) (cons prop + (remove-property + resource + (car + (sxml->namespaced-sxml prop namespaces))))) + properties)] + + ;; TODO handle xmllang correctly + [(d:set (d:prop . ,properties)) + (map (lambda (prop) (cons prop + (set-property resource + (sxml->namespaced-sxml prop namespaces)))) + properties)] + + [,else (scm-error 'bad-request "" + "Invalid propertyupdate: ~s" + (list body) + (list body))])))) + + ;; (format (current-error-port) "~s~%" continuations) + (let loop ((continuations continuations)) + (if (null? continuations) + '() + (let ((tag proc (car+cdr (car continuations)))) + (set! tag (sxml->namespaced-sxml tag namespaces)) + ;; (format (current-error-port) "tag: ~s~%" tag) + (catch #t (lambda () + ;; This is expected to throw quite often + (proc) + (cons (propstat 200 (list tag)) + (loop (cdr continuations)))) + (lambda err + (cons (propstat 409 (list tag)) + (mark-remaining-as-failed-dependency (cdr continuations))))))))] + + [,else (scm-error 'bad-request "" + "Invalid root element: ~s" + (list else) + (list else))]))) + + +(define (mark-remaining-as-failed-dependency pairs) + (map (lambda (item) + (propstat 424 (list (car item)))) + pairs)) diff --git a/module/calp/webdav/resource.scm b/module/calp/webdav/resource.scm new file mode 100644 index 00000000..47c5aded --- /dev/null +++ b/module/calp/webdav/resource.scm @@ -0,0 +1,15 @@ +(define-module (calp webdav resource) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource base) + :export (mount-resource!)) + +(define cm (module-public-interface (current-module))) +(module-use! cm (resolve-interface '(calp webdav resource base))) + +;;; TODO mount-resource! vs add-child! +;;; Would a good idea be that add-resource! adds directly, and should +;;; be considered internal, while mount-resource! also runs post-add +;;; hooks, and could thereby be exported +(define-method (mount-resource! (this <resource>) (child <resource>)) + (add-child! this child)) diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm new file mode 100644 index 00000000..500aef90 --- /dev/null +++ b/module/calp/webdav/resource/base.scm @@ -0,0 +1,598 @@ +(define-module (calp webdav resource base) + :use-module ((srfi srfi-1) :select (find remove last append-map drop-while)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module ((hnh util) :select (unless)) + :use-module (rnrs bytevectors) + :use-module (hnh util) + :use-module (hnh util env) + :use-module (datetime) + :export (<resource> + ;; href + href->string + string->href + href-relative + ;; local-path + name + dead-properties + ;; resource-children + resource? + children + + + + get-live-property + get-dead-property + get-property + + set-dead-property + set-dead-property! + set-live-property + set-live-property! + set-property + set-property! + + remove-dead-property + remove-dead-property! + remove-live-property + remove-live-property! + remove-property + remove-property! + + + setup-new-resource! + setup-new-collection! + + + + live-properties + add-child! + add-resource! + add-collection! + is-collection? + + content + set-content! + + copy-resource + copy-to-location! + move-to-location! + cleanup-resource + delete-child! + setup-new-resource! + ;; prepare-for-add! + + creationdate + displayname + getcontentlanguage + getcontentlength + getcontenttype + getetag + getlastmodified + lockdiscovery + resourcetype + supportedlock + + webdav-properties + + ;; absolute-path + ;; find-resource + lookup-resource + all-resources-under + + ;; dereference + + make-live-property + live-property? + property-getter + property-setter-generator + property-remover-generator + + prepare-update-properties + + )) + + +(define-record-type <live-property> + (make-live-property% getter setter-generator remover-generator) + live-property? + (getter property-getter) + (setter-generator property-setter-generator) + (remover-generator property-remover-generator)) + +(define* (make-live-property getter setter-generator optional: remover-generator) + (make-live-property% getter setter-generator remover-generator)) + + + +;; Collections are also resources, this is non-collection resources +(define-class <resource> () + ;; (href init-keyword: href: getter: href init-value: #f) + ;; (local-path init-keyword: local-path: getter: local-path) + + ;; name is a part of its search path. + ;; For example: the component located at /a/b + ;; would have name="a", its parent name="b", and the root element + ;; would have an unspecified name (probably the empty string, or "*root*") + (name init-keyword: name: getter: name) + + (dead-properties + ;; Map from (namespace . tagname) pairs to namespaced xml element + init-form: (make-hash-table) + getter: dead-properties%) + + ;; Attributes on data + (displayname accessor: displayname* init-value: #f) + (contentlanguage accessor: contentlanguage init-value: #f) + + ;; Direct children, used by @code{children} if not overwritten by child + (resource-children init-value: '() + accessor: resource-children) + + ;; Table containing href -> resource mappings, saves us from recursivly searching children each time. + (resource-cache init-value: (make-hash-table 0) + getter: resource-cache)) + +(define (resource? x) + (is-a? x <resource>)) + + +(define (href->string href) + (if (null? href) + "/" (string-join href "/" 'prefix))) + +(define (string->href s) + (remove string-null? + (string-split s #\/))) + +;; parent must be the head of child, elements in child after that is "free range" +(define (href-relative parent child) + (cond ((null? parent) child) + ((null? child) (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)) + ((equal? (car parent) (car child)) + (href-relative (cdr parent) (cdr child))) + (else (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)))) + +(define-method (children (self <resource>)) + (resource-children self)) + +;;; TODO merge content and set-content! into an accessor? +(define-method (content (self <resource>)) + (throw 'misc-error "content<resource>" + "Base <resource> doesn't implement (getting) content, please override this method" + '() #f)) + +(define-method (set-content! (self <resource>) content) + (throw 'msic-error "set-content!<resource>" + "Base <resource> doesn't implement (setting) content, please override this method" + '() #f)) + +(define-method (content-length (self <resource>)) + (if (is-collection? self) + 0 + (let ((c (content self))) + (cond ((bytevector? c) (bytevector-length c)) + ((string? c) (string-length c)) + (else -1))))) + +(define-method (write (self <resource>) port) + (catch #t + (lambda () + (display ; Make output atomic + (call-with-output-string + (lambda (port) + (format port "#<~a name=~s" + (class-name (class-of self)) + (name self)) + (cond ((displayname self) + propstat-200? + (lambda (name) (format port ", displayname=~s" name)))) + (format port ">"))) + port)) + (lambda _ + (format port "#<~a>" (class-name (class-of self)))))) + + +(define (add-resource! self new-name content) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (add-child! self resource collection?: #f) + (set-content! resource content) + resource))) + +(define (add-collection! self new-name) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (add-child! self resource collection?: #t) + resource))) + +(define (initialize-copied-resource! source copy) + (for-each (lambda (tag) (set-dead-property! copy tag)) + (dead-properties source)) + (set! (displayname* copy) (displayname* source) + (contentlanguage copy) (contentlanguage source)) + ;; (format (current-error-port) "Setting content! ~s (~s)~%" copy source) + (when (content source) + (set-content! copy (content source))) + ;; resource-cache should never be copied + ) + +(define-method (copy-resource (self <resource>) include-children?) + (copy-resource self include-children? #f)) + +(define-method (copy-resource (self <resource>) include-children? new-name) + (let ((resource (make (class-of self) name: (or new-name (name self))))) + (initialize-copied-resource! self resource) + (when include-children? + (for-each (lambda (c) (add-child! resource c)) + (map (lambda (c) (copy-resource c #t)) + (children self)))) + resource)) + +;; source and target-parent should be resource instances +;; new-name a string +;; include-children? and overwrite? booleans +(define* (copy-to-location! source target-parent + key: + (new-name (name source)) + include-children? + overwrite? + ) + (let ((copy (make (class-of source) name: new-name)) + ;; Take copy if child list. If we run `cp -r / /c` then; + ;; (at least when /c already exists) our child list gets + ;; updated, leading to an infinite loop if we use + ;; `(children source)` directly below. + (children-before (children source))) + (let ((status (add-child! target-parent copy + ;; (is-collection? copy) doesn't work for + ;; all types, since it's not quite yet + ;; added (for example: <file-resoure> + ;; checks if the target resource is a + ;; directory on the file system). + collection?: (is-collection? source) + overwrite?: overwrite?))) + (case status + ((created replaced) + (initialize-copied-resource! source copy) + (when include-children? + (for-each (lambda (c) (copy-to-location! + c copy + include-children?: #t)) + children-before)) + status) + ((collision) 'collision))))) + +(define* (move-to-location! source-parent source target-parent + key: + (new-name (name source)) + overwrite?) + (let ((status (copy-to-location! source target-parent + new-name: new-name + include-children?: #t + overwrite?: overwrite?))) + (case status + ((created replaced) + (delete-child! source-parent source) + status) + ((collision) 'collision)))) + + +;; Only tagname and namespaces are checked on the <xml-element> for the {get,set}-property + + +;;; All get-*-property methods return propstat elements + +(define (lookup-live-property resource xml-el) + (assoc-ref (live-properties resource) (xml-element-hash-key xml-el))) + +;;; TODO should {get,set}{,-{dead,live}}-property really be methods? +;;; - Live properties are defined by lookup-live-property, which isn't a +;;; method, which in turn calls live-properties, which MUST be a method. +;;; - Dead properties may have a reason. For example, file resources might +;;; want to store them directly in xattrs, ignoring its built in hash-table. +;;; - The combined should always just dispatch to either one + +(define-method (get-live-property (resource <resource>) xml-el) + (cond ((lookup-live-property resource xml-el) + => (lambda (pair) ((property-getter pair) resource))) + (else (propstat 404 (list (list xml-el)))))) + +(define-method (get-dead-property (resource <resource>) xml-el) + (cond ((hash-ref (dead-properties% resource) + (xml-element-hash-key xml-el)) + => (lambda (it) (propstat 200 (list it)))) + (else (propstat 404 (list (list xml-el)))))) + +;;; Return a list xml tags (including containing list) +(define-method (dead-properties (resource <resource>)) + (hash-map->list (lambda (_ v) v) + (dead-properties% resource))) + +;; Value should be a list with an <xml-element> in it's car +(define-method (set-dead-property (resource <resource>) value) + (unless (and (list? value) + (xml-element? (car value))) + (scm-error 'misc-error "set-dead-property" + "Invalid value, expected namespaced sxml" + '() #f)) + (lambda () + (hash-set! (dead-properties% resource) + (xml-element-hash-key (car value)) + value))) + +(define-method (set-live-property (resource <resource>) value) + (unless (and (list? value) + (xml-element? (car value))) + (scm-error 'misc-error "set-live-property" + "Invalid value, expected namespaced sxml" + '() #f)) + (cond ((lookup-live-property resource (car value)) + => (lambda (prop) (apply (property-setter-generator prop) + resource (cdr value)))) + (else #f))) + +(define (set-dead-property! resource value) + ((set-dead-property resource value))) + +(define (set-live-property! resource value) + ((set-live-property resource value))) + +(define (set-property resource value) + (or (set-live-property resource value) + (set-dead-property resource value))) + +(define (set-property! resource value) + ((set-property resource value))) + +;;; The remove-* procedures still take "correct" namespaced sxml (so an +;;; xml-element object inside a list). These extra lists are a bit of a waste, +;;; But allows remove-* to have the same signature as set-* + +(define-method (remove-dead-property (resource <resource>) xml-tag) + (unless (xml-element? xml-tag) + (scm-error 'misc-error "remove-dead-property" + "Bad property element" + '() #f)) + (lambda () + (hash-remove! (dead-properties% resource) + (xml-element-hash-key xml-tag)))) + +(define-method (remove-live-property (resource <resource>) xml-tag) + (unless (xml-element? xml-tag) + (scm-error 'misc-error "remove-live-property" + "Bad property element" + '() #f)) + + (cond ((lookup-live-property resource xml-tag) + => (lambda (prop) + (cond ((property-remover-generator prop) + => (lambda (f) (f resource))) + (else (throw 'irremovable-live-property))))) + (else #f))) + +(define (remove-dead-property! resource xml-tag) + ((remove-dead-property resource xml-tag))) + +(define (remove-live-property! resource xml-tag) + ((remove-live-property resource xml-tag))) + +(define-method (remove-property (resource <resource>) xml-tag) + (or (remove-live-property resource xml-tag) + (remove-dead-property resource xml-tag))) + +(define (remove-property! resource xml-tag) + ((remove-property resource xml-tag))) + + + +;; xml-tag should be just the tag element, without a surounding list +(define-method (get-property (resource <resource>) xml-tag) + (cond ((get-dead-property resource xml-tag) + propstat-200? => identity) + (else (get-live-property resource xml-tag)))) + +;; Return an alist from xml-element tags (but not full elements with surrounding list) +;; to generic procedures returning that value. +;; SHOULD be extended by children, which append their result to this result +;; @example +;; (define-method (live-properties (self <specific-resource>) +;; (append (next-method) +;; specific-resource-properties)) +;; @end example +(define-method (live-properties (self <resource>)) + (map (lambda (pair) (cons (xml-element-hash-key (xml webdav (car pair))) (cdr pair))) + webdav-properties)) + +(define-method (setup-new-resource! (this <resource>) (parent <resource>)) + 'noop) + +(define-method (setup-new-collection! (this <resource>) (parent <resource>)) + 'noop) + +(define (add-child* this child collection?) + (setup-new-resource! child this) + (when collection? + (setup-new-collection! child this)) + (set! (resource-children this) + (cons child (resource-children this)))) + +(define* (add-child! this child + key: + overwrite? + (collection? (is-collection? child))) + (let ((existing (lookup-resource this (list (name child))))) + (cond ((and overwrite? existing) + (delete-child! this existing) + (add-child* this child collection?) + 'replaced) + (existing 'collision) + (else + (add-child* this child collection?) + 'created)))) + + +;; Free any aditional system resources held by this object. +;; For example, file resources will remove the underlying file here. +(define-method (cleanup-resource (this <resource>)) + 'noop) + +(define-method (delete-child! (this <resource>) (child <resource>)) + (set! (resource-children this) + (delq1! child (children this))) + (for-each (lambda (grandchild) + (delete-child! child grandchild)) + (children child)) + (cleanup-resource child)) + + + +;;; TODO rename to simply @code{collection?} +(define-method (is-collection? (self <resource>)) + (not (null? (resource-children self)))) + + + + +(define-method (creationdate (self <resource>)) + (propstat 501 `((,(xml webdav 'creationdate))))) + +(define-method (set-creationdate! (self <resource>) _) + (throw 'protected-resource "creationdate")) + +(define-method (displayname (self <resource>)) + (cond ((displayname* self) + => (lambda (name) + (propstat 200 `((,(xml webdav 'displayname) + ,name))))) + (else + (propstat 404 `((,(xml webdav 'displayname))))))) + +(define-method (set-displayname! (self <resource>) value) + (lambda () (set! (displayname* self) value))) + +(define-method (getcontentlanguage (self <resource>)) + (cond ((contentlanguage self) + => (lambda (lang) (propstat 200 `((,(xml webdav 'getcontentlanguage) ,lang))))) + (else (propstat 404 `((,(xml webdav 'getcontentlanguage))))))) + +(define-method (set-getcontentlanguage! (self <resource>) value) + (lambda () (set! (contentlanguage self) value))) + +(define-method (getcontentlength (self <resource>)) + (propstat 501 `((,(xml webdav 'getcontentlength))))) + +(define-method (getcontentlength (self <resource>)) + (propstat 200 + (list + (list (xml webdav 'getcontentlength) + (content-length self))))) + +(define-method (set-getcontentlength! (self <resource>) _) + (throw 'protected-resource "getcontentlength")) + +(define-method (getcontenttype (self <resource>)) + (propstat 501 `((,(xml webdav 'getcontenttype))))) + +(define-method (set-getcontenttype! (self <resource>) _) + (throw 'protected-resource "getcontenttype")) + +(define-method (getetag (self <resource>)) + ;; TODO + (propstat 501 `((,(xml webdav 'getetag))))) + +(define-method (set-getetag! (self <resource>) _) + (throw 'protected-resource "getetag")) + +(define-method (getlastmodified (self <resource>)) + (propstat 200 `((,(xml webdav 'getlastmodified) + ,(with-locale1 + LC_TIME "C" + (lambda () + (datetime->string (unix-time->datetime 0) "~a, ~d ~b ~Y ~H:~M:~S GMT"))))))) + +(define-method (set-getlastmodified! (self <resource>) _) + (throw 'protected-resource "getlastmodified")) + +(define-method (lockdiscovery (self <resource>)) + (propstat 200 `((,(xml webdav 'lockdiscovery) + ())))) + +(define-method (set-lockdiscovery! (self <resource>) _) + (throw 'protected-resource "lockdiscovery")) + +(define-method (resourcetype (self <resource>)) + (propstat 200 `((,(xml webdav 'resourcetype) + ,@(when (is-collection? self) + `((,(xml webdav 'collection)))))))) + +(define-method (set-resourcetype! (self <resource>) _) + (throw 'protected-resource "resourcetype")) + +(define-method (supportedlock (self <resource>)) + (propstat 200 `((,(xml webdav 'supportedlock) ())))) + +(define-method (set-supportedlock! (self <resource>) _) + (throw 'protected-resource "supportedlock")) + +(define webdav-properties + `((creationdate . ,(make-live-property creationdate set-creationdate!)) + (displayname . ,(make-live-property displayname set-displayname!)) + (getcontentlanguage . ,(make-live-property getcontentlanguage set-getcontentlanguage!)) + (getcontentlength . ,(make-live-property getcontentlength set-getcontentlength!)) + (getcontenttype . ,(make-live-property getcontenttype set-getcontenttype!)) + (getetag . ,(make-live-property getetag set-getetag!)) + (getlastmodified . ,(make-live-property getlastmodified set-getlastmodified!)) + (lockdiscovery . ,(make-live-property lockdiscovery set-lockdiscovery!)) + (resourcetype . ,(make-live-property resourcetype set-resourcetype!)) + (supportedlock . ,(make-live-property supportedlock set-supportedlock!)))) + + + +;;; TODO remove! This is a remnant of the old mount system +;; (define-method (dereference (self <resource>)) +;; self) + +(define (find-resource resource path) + ;; Resource should be a <resource> (or something descended from it) + ;; path should be a list of strings + (cond ((null? path) resource) + ((string-null? (car path)) + ;; resource + (find-resource resource (cdr path))) + ((find (lambda (r) (string=? (car path) (name r))) + (children resource)) + => (lambda (r) (find-resource r (cdr path)))) + (else #f))) + +;; Lookup up a given resource first in the cache, +;; Then in the tree +;; and finaly fails and returns #f +(define (lookup-resource root-resource path) + (find-resource root-resource path) + #; + (or (hash-ref (resource-cache root-resource) path) + (and=> (find-resource root-resource path) + (lambda (resource) + (hash-set! (resource-cache root-resource) path resource) + resource)))) + +(define* (all-resources-under* resource optional: (prefix '())) + (define s (append prefix (list (name resource)))) + (cons (cons s resource) + (append-map (lambda (c) (all-resources-under* c s)) + (children resource)))) + +;; Returns a flat list of this resource, and all its decendants +(define* (all-resources-under resource optional: (prefix '())) + (cons (cons prefix resource) + (append-map (lambda (c) (all-resources-under* c prefix)) + (children resource)))) diff --git a/module/calp/webdav/resource/calendar.scm b/module/calp/webdav/resource/calendar.scm new file mode 100644 index 00000000..314d66aa --- /dev/null +++ b/module/calp/webdav/resource/calendar.scm @@ -0,0 +1,27 @@ +(define-module (calp webdav resource calendar) + ;; :use-module (hnh util) + ;; :use-module (datetime) + ;; :use-module (sxml namespaced util) + ;; :use-module (calp webdav property) + ;; :use-module (ice-9 hash-table) + :use-module (calp webdav resource calendar collection) + :use-module (calp webdav resource calendar object) + :export ( + calendar-resource? +) + ) + +(define cm (module-public-interface (current-module))) +(module-use! cm (resolve-interface '(calp webdav resource calendar collection))) +(module-use! cm (resolve-interface '(calp webdav resource calendar object))) + +(define (calendar-resource? x) + (or (calendar-collection-resource? x) + (calendar-object-resource? x))) + + + + + + + diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm new file mode 100644 index 00000000..e1bf73fd --- /dev/null +++ b/module/calp/webdav/resource/calendar/collection.scm @@ -0,0 +1,295 @@ +(define-module (calp webdav resource calendar collection) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :use-module ((vcomponent) :prefix vcs-) + :use-module ((vcomponent base) + :select (type prop vcomponent)) + + :use-module (web request) + :use-module (web uri) + + :use-module ((calp namespaces) :select (webdav caldav)) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (ice-9 hash-table) + + :use-module (hnh util) + + :use-module (calp webdav resource calendar object) + ;; propfind-most-live-properties propfind-all-dead-properties propname uri-path request-uri type + :export (<calendar-collection-resource> + caldav-properties + calendar-collection-resource?) + ) + +;;; Resoruces containing calendar components +(define-class <calendar-collection-resource> (<resource>) + (description init-value: #f + accessor: description) + (data-store getter: data-store + init-keyword: store:)) + + +(define-method (is-collection? (_ <calendar-collection-resource>)) + #t) + + + +(define-method (children (this <calendar-collection-resource>)) + (map (lambda (ev) + (make <calendar-object-resource> + name: (prop ev 'UID) + component: ev)) + (vcs-children this))) + +(define (calendar-collection-resource? x) + (is-a? x <calendar-collection-resource>)) + + +(define-method (base-timezone <calendar-collection-resource>) + ;; (zoneinfo->vtimezone '() "Europe/Stockholm" 'ev) + (vcomponent type: 'VTIMEZONE) + ) + + + +(define-method (live-properties (self <calendar-collection-resource>)) + (append (next-method) + (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair))) + caldav-properties))) + + + + +(define-method (displayname (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml webdav 'displayname) + ,(prop (content self) 'displayname))))) + + +(define-method (resourcetype (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml webdav 'resourcetype) + (,(xml caldav 'calendar)))))) + +;;; CALDAV Properties + +(define-method (calendar-description (self <calendar-collection-resource>)) + (cond ((description self) + => (lambda (it) + (propstat 200 + (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en")))) + it))))) + (else + (propstat 404 (list (list (xml caldav 'calendar-description))))))) + +(define-method (calendar-timezone (self <calendar-collection-resource>)) + (propstat 200 + (list + (list (xml caldav 'calendar-description) + (call-with-output-string + (lambda (port) + (ics:serialize (base-timezone self) port))))))) + +(define-method (supported-calendar-component-set (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml caldav 'supported-calendar-component-set) + (,(xml caldav 'comp + (alist->hashq-table '((name . "VEVENT"))))))))) + +(define-method (supported-calendar-data (self <calendar-collection-resource>)) + (propstat 200 + (list + (list + (xml caldav 'supported-calendar-data) + (map (lambda (content-type) + (list (xml caldav 'calendar-data + (alist->hashq-table + '((content-type . ,content-type) + (version . "2.0")))))) + '("text/calendar" + "application/calendar+xml")))))) + + + +;; (define-method (max-resource-size (self <calendar-collection-resource>)) +;; ) + +;; (define-method (min-date-time )) +;; (define-method (max-date-time )) +;; (define-method (max-instances )) +;; (define-method (max-attendees-per-instance )) + +(define-method (supported-collation-set (self <calendar-collection-resource>)) + (propstat 200 + (list `(,(xml caldav 'supported-collation-set) + ,@(map (lambda (cs) `(,(xml caldav 'supported-collation) ,cs)) + `(;; Required by CalDAV + "i;ascii-casemap" + "i;octet" + ;; Added (RFC 5051)) + "i;unicode-casemap")))))) + + + +(define caldav-properties + `((calendar-description . ,calendar-description) + (calendar-timezone . ,calendar-timezone) + (supported-calendar-component-set . ,supported-calendar-component-set) + (supported-calendar-data . ,supported-calendar-data) + (supported-collation-set . ,supported-collation-set) + ;; (max-resource-size . ,max-resource-size) + ;; (min-date-time . ,min-date-time) + ;; (max-date-time . ,max-date-time) + ;; (max-instances . ,max-instances) + ;; (max-attendees-per-instance . ,max-attendees-per-instance) + )) + +;;; Reports + +(define-method (supported-reports* (this <calendar-collection-resource>)) + (append (next-method) + (list + ;; Required for ACL, but not for CalDAV + ;; (xml webdav 'version-tree) + ;; Optional for ACL, but REQUIRED for CalDAV + (cons (xml webdav 'expand-property) expand-property) + ;; REQUIRED by CalDAV + (cons (xml caldav 'calendar-query) calendar-query) + (cons (xml caldav 'calendar-multiget) calendar-multiget) + (cons (xml caldav 'free-busy-report) free-busy-report) + ))) + + +(define-method (calendar-query (this <calendar-collection-resource>) headers body) + ;; Request body MUST be a caldav:calendar-query + ;; Request MAY include a depth header, default = 0 + ;; Respnose-body MUST be a dav:multistatus + ;; Responseb body MUST contain DAV:respons element for each iCalendar object that matched the search filter + + (let ((allprop (find-element (xml webdav 'allprop) (cdr body))) + (propname (find-element (xml webdav 'propname) (cdr body))) + (prop (find-element (xml webdav 'prop) (cdr body))) + (filter (find-element (xml caldav 'filter) (cdr body))) + (timezone (find-element (xml caldav 'timezone) (cdr body)))) + (when (< 1 (count identity (list allprop propname prop))) + (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive")) + + (unless filter + (throw 'bad-request 400 "filter required")) + + + #; + (when timezone + (case (assoc-ref (attributes timezone) 'content-type) + ((application/calendar+xml) + (xcs:serialize default-timezone)) + ;; ((application/calendar+json)) + (else ; includes text/calendar + (ics:serialieze default-timezone) + ))) + + (let ((resources (select-components-by-comp-filter this comp-filter))) + `(,(xml webdav 'multistatus) + ,@(for (href . resource) in resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (merge-propstats + (cond (allprop + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + (list (propstat + 200 + (map (compose list car) + (append (dead-properties resource) + (live-properties resource)))))) + (prop + (map (lambda (prop) (get-property resource prop)) + prop))))))))))) + + + + +(define-method (expand-property (this <calendar-collection-resource>) request body)) + +(define-method (free-busy-report (this <calendar-collection-resource>) request body)) + +(define-method (calendar-multiget (this <calendar-collection-resource>) request body) + (define base-href (-> request request-uri uri-path href->string)) + (let ((allprop (find-element (xml webdav 'allprop) (cdr body))) + (propname (find-element (xml webdav 'propname) (cdr body))) + (prop (find-element (xml webdav 'prop) (cdr body))) + (hrefs (find-elements (xml webdav 'href) (cdr body)))) + (when (< 1 (count identity (list allprop propname prop))) + (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive")) + (when (null? hrefs) + (throw 'bad-request 400 "At least one href is required")) + + ;; (assert (memv href hrefs)) + + (let ((resources + (for href in hrefs + (cons href + (lookup-resource + this + (href-relative base-href href)))))) + `(,(xml webdav 'multistatus) + (for (href . resource) in resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(cond (resource + (cond (allprop + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + (list (propstat + 200 + ;; car to get tagname, list to construct a valid xml element + (map (compose list car) + (append + (dead-properties resource) + (live-properties resource)))))) + (prop + (propfind-selected-properties + resource + (map car (cdr prop)))))) + (else + `(,(xml webdav 'status) + ,(http-status-line 404)))))))))) + + + + +(define-method (select-components-by-comp-filter (this <calendar-collection-resource>) comp-filter) + ) + + +;;; TODO +(define (overlaps? a b) + #t) + +(define (comp-filter scope filter) + ;; CaldDAV 9.7.1 + (or (and (null? (children filter)) + (eq? (attribute filter 'name) + (type scope))) + (and (find-element (xml caldav 'is-not-defined) + (children filter)) + (not + (find (lambda (el) (eq? (type el) (attribute filter 'name))) + (children scope)))) + (and (cond ((find-element (xml caldav 'time-range) + (children filter)) + => (lambda (range) + (overlaps? scope range))) + (else #f)) + (every (lambda (filt) (comp-filter scope filt)) (children filter))) + (every (lambda (filt) (comp-filter scope filt)) (children filter)))) diff --git a/module/calp/webdav/resource/calendar/object.scm b/module/calp/webdav/resource/calendar/object.scm new file mode 100644 index 00000000..82a8c18e --- /dev/null +++ b/module/calp/webdav/resource/calendar/object.scm @@ -0,0 +1,76 @@ +(define-module (calp webdav resource calendar object) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :use-module ((vcomponent formats xcal) :prefix #{xcs:}#) + :use-module ((vcomponent) :prefix vcs-) + :use-module ((calp namespaces) :select (webdav)) + :use-module (calp webdav property) + :use-module (sxml namespaced) + + :export (<calendar-object-resource> + calendar-object-resource? + component) + ) + +;;; content% + +(define-class <calendar-object-resource> (<resource>) + (component getter: component + init-keyword: component:)) + + + +(define-method (is-collection? (_ <calendar-object-resource>)) + #f) + + + +(define-method (children (_ <calendar-object-resource>)) + '()) + +(define (calendar-object-resource? x) + (is-a? x <calendar-object-resource>)) + +(define-method (content (self <calendar-object-resource>) content-type) + (case content-type + ((text/calendar) + (call-with-output-string (lambda (port) (ics:serialize (content% self) port)))) + ((application/calendar+xml) + (call-with-output-string (lambda (port) (xcs:serialize (content% self) port)))) + ;; ((text/html)) + ;; ((application/xhtml+xml)) + ;; ((application/calendar+json)) + (else (content self 'text/calendar)) + ) + ) + +(define-method (creationdate (self <calendar-object-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + (-> (content self) + (prop 'CREATED) + ;; TODO timezone + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + + +(define-method (getcontentlength (self <calendar-object-resource>)) + ;; TODO which representation should be choosen to calculate length? + (propstat 501 `((,(xml webdav 'getcontentlength))))) + + + +(define-method (getcontenttyype (self <calendar-object-resource>)) + ;; TODO different representations + (propstat 200 `((,(xml webdav 'getcontentlength) + "text/calendar")))) + + +(define-method (getlastmodified (self <calendar-object-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + (string->datetime (prop (content self) 'LAST-MODIFIED) + "~Y~m~dT~H~M~S"))))) diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm new file mode 100644 index 00000000..e2fec9a5 --- /dev/null +++ b/module/calp/webdav/resource/file.scm @@ -0,0 +1,192 @@ +(define-module (calp webdav resource file) + :use-module (srfi srfi-1) + :use-module (oop goops) + :use-module (hnh util) + :use-module (hnh util env) + :use-module (hnh util path) + :use-module (datetime) + :use-module (ice-9 popen) + :use-module (ice-9 rdelim) + :use-module (ice-9 ftw) + :use-module (sxml namespaced) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors) + :export (<file-resource> file-resource? root ; path + )) + +;;; Resources backed by the filesystem +(define-class <file-resource> (<resource>) + ;; Directory to act as root for this file tree. + ;; Should be inherited by all children + + ;; DO NOT export the setters. These fields needs to be carefully managed to + ;; ensure that they stay consistant with the @var{name} trail. + (root getter: root setter: set-root! init-value: "/" init-keyword: root:) + (path getter: path setter: set-path! init-value: "/" init-keyword: path:)) + +(define-method (write (self <file-resource>) port) + (display + (format #f "#<<file-resource> name=~s, root=~s, path=~s>" + (name self) + (root self) + (path self)) + port)) + +(define (file-resource? x) + (is-a? x <file-resource>)) + +;; TODO this is global, so most certanly leaks info between different +;; <file-resource> trees. +(define *realized-resource* (make-hash-table)) + +(define (file-resource-for-path root path) + (or (hash-ref *realized-resource* path) + (let ((resource (make <file-resource> + ;; href: + root: root + ; local-path: path + name: (basename path) + path: path + ))) + (hash-set! *realized-resource* path resource) + resource))) + +(define (filepath self) + (path-append (root self) + (path self))) + +(define-method (children (self <file-resource>)) + ;; (format (current-error-port) "root=~s, path=~s~%" + ;; (root self) + ;; (local-path self)) + (when (is-collection? self) + (map (lambda (p) (file-resource-for-path (root self) + (path-append (path self) + p))) + (remove (lambda (p) (member p '("." ".."))) + (scandir (filepath self)))))) + +(define-method (is-collection? (self <file-resource>)) + (eq? 'directory (stat:type (stat (filepath self))))) + +(define (file-creation-date path) + (let ((pipe (open-pipe* OPEN_READ "stat" "-c" "%W" path))) + (begin1 (unix-time->datetime (read pipe)) + (close-pipe pipe)))) + +(define (mimetype path) + (let ((pipe (open-pipe* OPEN_READ "file" "--brief" "--mime-type" + path))) + (begin1 (read-line pipe) + (close-pipe pipe)))) + +(define-method (creationdate (self <file-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + ,(with-locale1 + LC_TIME "C" + (lambda () + (-> (file-creation-date (filepath self)) + (datetime->string "~Y-~m-~dT~H:~M:~S~Z")))))))) + +(define-method (content (self <file-resource>)) + (if (is-collection? self) + #f + (call-with-input-file (filepath self) + get-bytevector-all binary: #t))) + +(define-method (set-content! (self <file-resource>) data) + (cond ((bytevector? data) + (call-with-output-file (filepath self) + (lambda (port) (put-bytevector port data)))) + ((string? data) + (call-with-output-file (filepath self) + (lambda (port) (put-string port data)))) + (else (scm-error 'misc-error "set-content!<file-resource>" + "Content must be bytevector or string: ~s" + (list data) #f)))) + + +(define-method (setup-new-resource! (self <file-resource>) + (parent <file-resource>)) + (next-method) + (set-root! self (root parent)) + (set-path! self (path-append (path parent) (name self)))) + +(define-method (setup-new-collection! (self <file-resource>) + (parent <file-resource>)) + (next-method) + (mkdir (filepath self))) + +(define-method (cleanup-resource (self <file-resource>)) + ((if (is-collection? self) + rmdir + delete-file) + (filepath self))) + +(define-method (content-length (self <file-resource>)) + (-> (filepath self) stat stat:size)) + + +(define-method (getcontenttype (self <file-resource>)) + ;; TODO 404 if collection + ;; Or just omit it? + (propstat 200 `((,(xml webdav 'getcontenttype) + ,(mimetype (filepath self)))))) + +(define-method (getlastmodified (self <file-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + ,(with-locale1 + LC_TIME "C" + (lambda () + (-> (filepath self) + stat + stat:mtime + unix-time->datetime + (datetime->string "~a, ~d ~b ~Y ~H:~M:~S GMT")))))))) + +;; (define (xattr-key xml-el) +;; (format #f "caldav.~a" +;; (base64-encode +;; (format #f "~a:~a" +;; (xml-element-namespace xml-el) +;; (xml-element-tagname xml-el))))) + + +;; (define-method (set-dead-property (self <file-resource>) value) +;; (unless (and (list? value) +;; (xml-element? (car value))) +;; (scm-error 'misc-error "set-dead-property" +;; "Invalid value, expected namespaced sxml" +;; '() #f)) +;; (catch #t +;; (lambda () +;; (lambda () +;; (xattr-set! +;; (filename self) +;; (xattr-key (car value)) +;; (with-output-to-string +;; (lambda () (namespaced-sxml->xml value)))))) +;; (lambda _ (next-method)))) + + +;; (define-method (get-dead-property (self <file-resource>) +;; xml-el) +;; (catch #t +;; (lambda () +;; (propstat 200 +;; (list +;; (xattr-ref (filepath self) +;; (xattr-key el))))) +;; (lambda _ (next-method)))) + + +;; (define-method (remove-dead-property (self <file-resource>) +;; xml-el) +;; (catch #t +;; (lambda () (xattr-remove! (filepath self) xml-el)) +;; (lambda _ (next-method)))) diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm new file mode 100644 index 00000000..1d2d5d31 --- /dev/null +++ b/module/calp/webdav/resource/virtual.scm @@ -0,0 +1,71 @@ +(define-module (calp webdav resource virtual) + :use-module (oop goops) + :use-module (datetime) + :use-module (rnrs bytevectors) + :use-module (hnh util) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :export (<virtual-resource> + virtual-resource? + virtual-ns + ;; content + isvirtual + ) + ) + +(define virtual-ns (string->symbol "http://example.com/virtual")) + +(define-class <virtual-resource> (<resource>) + (content* init-value: #vu8() + init-keyword: content: + accessor: content*) + (creation-time init-form: (current-datetime) + init-keyword: creation-time: + getter: creation-time)) + +(define (virtual-resource? x) + (is-a? x <virtual-resource>)) + +(define-method (write (self <virtual-resource>) port) + (format port "#<<virtual-resource> name=~s, creation-time=~s, content=~s>" + (name self) + (creation-time self) + (content self))) + +(define-method (live-properties (self <virtual-resource>)) + (append + (next-method) + (list (cons (xml-element-hash-key (xml virtual-ns 'isvirtual)) (make-live-property isvirtual set-isvirtual!))))) + +(define-method (content (self <virtual-resource>)) + (content* self)) + +(define-method (set-content! (self <virtual-resource>) data) + (set! (content* self) data)) + +(define-method (creationdate (self <virtual-resource>)) + (propstat 200 + (list + (list (xml webdav 'creationdate) + (-> (creation-time self) + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + + +(define-method (getcontenttype (self <resource>)) + (propstat 200 + (list + (list (xml webdav 'getcontenttype) + "application/binary")))) + +(define-method (isvirtual (self <virtual-resource>)) + (propstat 200 + (list + (list (xml virtual-ns 'isvirtual) + "true")))) + + +(define-method (set-isvirtual! (self <virtual-resource>) _) + (throw 'protected-resource "isvirtual")) diff --git a/module/datetime.scm b/module/datetime.scm index 8bba6e89..d54ba403 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -3,8 +3,6 @@ :replace (second) :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-9 gnu) :use-module (srfi srfi-41) :use-module (srfi srfi-71) :use-module (srfi srfi-88) @@ -15,12 +13,13 @@ -> ->> swap - set label span-upto - set-> )) + :use-module (hnh util object) + :use-module (hnh util lens) + :use-module (ice-9 i18n) :use-module (ice-9 format) :use-module (ice-9 regex) @@ -37,8 +36,11 @@ datetime datetime? - get-date - get-timezone + ;; get-date + ;; get-timezone + datetime-date + datetime-time + tz date-zero? time-zero? @@ -171,45 +173,40 @@ pre: (ensure (lambda (x) (<= sun x sat)))) -;;; RECORD TYPES - -;;; DATE - -(define-immutable-record-type <date> - (make-date year month day) - date? - (year year) (month month) (day day)) - -(define* (date key: (year 0) (month 0) (day 0)) - (unless (and (integer? year) (integer? month) (integer? day)) - (scm-error 'wrong-type-arg "date" - "Year, month, and day must all be integers. ~s, ~s, ~s" - (list year month day) - #f)) - (make-date year month day)) -(set-record-type-printer! - <date> (lambda (r p) (display (date->string r "#~1") p))) - - -;;; TIME - -(define-immutable-record-type <time> - (make-time hour minute second) - time? - (hour hour) (minute minute) (second second)) - -(define* (time key: (hour 0) (minute 0) (second 0)) - (unless (and (integer? hour) (integer? minute) (integer? second)) - (scm-error 'wrong-type-arg "time" - "Hour, minute, and second must all be integers. ~s, ~s, ~s" - (list hour minute second) - #f)) - (make-time hour minute second)) +;;; RECORD TYPES -(set-record-type-printer! - <time> - (lambda (r p) (display (time->string r "#~3") p))) +(define-type (date printer: (lambda (r p) (display (date->string r "#~1") p))) + (year default: 0 type: integer?) + (month default: 0 type: integer?) + (day default: 0 type: integer?)) + +(define-type (time printer: (lambda (r p) (display (time->string r "#~3") p))) + (hour default: 0 type: integer?) + (minute default: 0 type: integer?) + (second default: 0 type: integer?)) + +(define (datetime-constructor-constructor constructor validator) + (let ((date% date) + (time% time)) + (lambda* (key: date time tz + (year 0) (month 0) (day 0) + (hour 0) (minute 0) (second 0)) + (let ((date (or date (date% year: year month: month day: day))) + (time (or time (time% hour: hour minute: minute second: second)))) + (validator date time tz) + (constructor date time tz))))) + +(define-type (datetime + constructor: datetime-constructor-constructor + printer: (lambda (r p) + (if (and (tz r) (not (string=? "UTC" (tz r)))) + (write (datetime->sexp r) p) + (display (datetime->string r "#~1T~3~Z") p)))) + + (datetime-date type: date?) + (datetime-time type: time?) + tz) (define (date-zero? date) @@ -218,53 +215,14 @@ (define (time-zero? time) (= 0 (hour time) (minute time) (second time))) -;;; DATETIME - -(define-immutable-record-type <datetime> - (make-datetime date time tz) - datetime? - (date get-date) - (time get-time%) - (tz tz) ; #f for localtime, "UTC", "Europe/Stockholm", ... - ) - -(define (get-timezone datetime) - (tz datetime)) - - -(define* (datetime - key: date time - (year 0) (month 0) (day 0) - (hour 0) (minute 0) (second 0) - tz) - (let ((date (or date (make-date year month day))) - (time (or time (make-time hour minute second)))) - (unless (date? date) - (scm-error 'wrong-type-arg "datetime" - "Date must be a date object, got ~s" - (list date) (list date))) - (unless (time? time) - (scm-error 'wrong-type-arg "datetime" - "Time must be a time object, got ~s" - (list time) (list time))) - (make-datetime date time tz))) - -(set-record-type-printer! - <datetime> - (lambda (r p) - (if (and (tz r) (not (string=? "UTC" (tz r)))) - (write (datetime->sexp r) p) - (display (datetime->string r "#~1T~3~Z") p)))) - - ;; NOTE there isn't any stable way to craft the tm objects. ;; I could call mktime on some date, and replace the fields ;; with the set-tm:*, but that is worse that breaking the API. (define (datetime->tm datetime) - (let ((t (get-time% datetime)) - (d (get-date datetime))) + (let ((t (datetime-time datetime)) + (d (datetime-date datetime))) (vector (second t) (minute t) (hour t) @@ -296,8 +254,8 @@ (define (unix-time->datetime n) ;; tm->datetime returns GMT here (as hinted by the ;; name @var{gmtime}). Blindly change it to UTC. - (set (tz (tm->datetime (gmtime n))) - "UTC")) + (-> (tm->datetime (gmtime n)) + (tz "UTC"))) ;; this returns UTC time, with a TZ component set to "UTC" @@ -305,7 +263,7 @@ (unix-time->datetime ((@ (guile) current-time)))) (define (current-date) - (get-date (current-datetime))) + (datetime-date (current-datetime))) @@ -324,10 +282,11 @@ [(string=? "local" (tz dt)) (mktime v)] [else (mktime v (tz dt))]))))) ;; strip tz-name, to conform with my local time. - (set (tz (tm->datetime tm)) #f)))) + (-> (tm->datetime tm) + (tz #f))))) (define (as-date date/-time) - (cond [(datetime? date/-time) (get-date date/-time)] + (cond [date/-time datetime? => datetime-date] [(date? date/-time) date/-time] [(time? date/-time) (date)] [else (scm-error 'wrong-type-arg @@ -337,7 +296,7 @@ #f)])) (define (as-time date/-time) - (cond [(datetime? date/-time) (get-time% date/-time)] + (cond [date/-time datetime? => datetime-time] [(date? date/-time) (time)] [(time? date/-time) date/-time] [else (scm-error 'wrong-type-arg "as-time" @@ -379,15 +338,15 @@ 366 365)) (define (start-of-month date) - (set (day date) 1)) + (-> date (day 1))) (define (end-of-month date) - (set (day date) (days-in-month date))) + (-> date (day (days-in-month date)))) (define (start-of-year date) - (set-> date - (day 1) - (month 1))) + (-> date + (day 1) + (month 1))) (define (date-stream date-increment start-day) (stream-iterate (lambda (d) (date+ d date-increment)) @@ -624,10 +583,10 @@ (prev-month-len (days-in-month (date- date* (date month: 1)))) (month-start (modulo (- (week-day date*) week-start) 7))) (values - (map (lambda (d) (set (day (date- date* (date month: 1))) d)) + (map (lambda (d) (-> date* (date- (date month: 1)) (day d))) (iota month-start (1+ (- prev-month-len month-start)))) - (map (lambda (d) (set (day date*) d)) (iota month-len 1)) - (map (lambda (d) (set (day (date+ date* (date month: 1))) d)) + (map (lambda (d) (day date* d)) (iota month-len 1)) + (map (lambda (d) (-> date* (date+ (date month: 1)) (day d))) (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))) @@ -664,17 +623,17 @@ (let ((date-diff (cond [start-date - (let ((end-date (date+ start-date (get-date dt)))) - (1- (days-in-interval start-date end-date))) ] - [(or (not (zero? (month (get-date dt)))) - (not (zero? (year (get-date dt))))) + (let ((end-date (date+ start-date (datetime-date dt)))) + (1- (days-in-interval start-date end-date)))] + [(or (not (zero? (month (datetime-date dt)))) + (not (zero? (year (datetime-date dt))))) (scm-error 'misc-error "datetime->decimal-hour" "Multi-month intervals only supported when start-date is given (~a)" (list dt) #f)] - [else (day (get-date dt))]))) - (+ (time->decimal-hour (get-time% dt)) - (* date-diff 24)))) + [else (-> dt datetime-date day)]))) + (-> dt datetime-time time->decimal-hour + (+ (* date-diff 24))))) ;; Returns a list of all dates from start to end. ;; both inclusive @@ -693,8 +652,8 @@ (fmt "~1T~3") (locale %global-locale) key: allow-unknown?) - (define date (get-date datetime)) - (define time (get-time% datetime)) + (define date (datetime-date datetime)) + (define time (datetime-time datetime)) (with-output-to-string (lambda () (fold (lambda (token state) @@ -718,7 +677,7 @@ ((#\a) (display (week-day-name (week-day date) 3 locale: locale))) ((#\B) (display (locale-month (month date) locale))) ((#\b) (display (locale-month-short (month date) locale))) - ((#\Z) (when (equal? "UTC" (get-timezone datetime)) (display "Z"))) + ((#\Z) (when (equal? "UTC" (tz datetime)) (display "Z"))) (else (unless allow-unknown? (scm-error 'misc-error "datetime->string" "Invalid format token ~a" @@ -777,14 +736,6 @@ Returns -1 on failure" (define* (loop str fmt dt optional: (ampm ampm)) (loop* str fmt dt ampm)) - (define time (get-time% dt)) - (define date (get-date dt)) - (define zone (get-timezone dt)) - (define (as-dt dt) - (cond [(date? dt) (datetime date: dt time: time tz: zone)] - [(time? dt) (datetime date: date time: dt tz: zone)] - [else dt])) - (cond [(and (null? str) (null? fmt)) (ampm dt)] [(null? str) @@ -811,7 +762,7 @@ Returns -1 on failure" (if (eq? #\Z (car str)) (loop (cdr str) (cddr fmt) - (set (tz dt) "UTC")) + (tz dt "UTC")) (loop str (cddr fmt) dt))] @@ -825,17 +776,13 @@ Returns -1 on failure" (case (string-ref (match:substring m 1) 0) ((#\a #\A) (lambda (dt) - (datetime date: (get-date dt) - time: (if (= 12 (hour (get-time% dt))) - (set (hour (get-time% dt)) 0) - (get-time% dt))))) + (modify* dt datetime-time hour + (lambda (x) (if (= x 12) 0 x))))) ((#\p #\P) (lambda (dt) - (datetime date: (get-date dt) - time: (if (= 12 (hour (get-time% dt))) - (get-time% dt) - (set (hour (get-time% dt)) - (+ 12 (hour (get-time% dt)))))))))) + (modify* dt datetime-time hour + (lambda (x) (if (= x 12) + x (+ x 12)))))))) )) ;; fail here? (else (loop str (cddr fmt) dt))) @@ -853,8 +800,8 @@ Returns -1 on failure" ((next-char rest ...) (span (lambda (c) (not (eqv? c next-char))) str))))) (loop post (cddr fmt) - (as-dt (set (month date) - (parse-month (list->string head) locale)))))] + (set dt datetime-date month + (parse-month (list->string head) locale))))] [(#\H #\M #\S #\m #\d) ;; This captures both the possibility of a date with a single digit, ;; e.g. 7 may, but also compact, digits only, form without delimiters, @@ -864,13 +811,14 @@ Returns -1 on failure" (loop post (cddr fmt) - (as-dt - (case (cadr fmt) - [(#\H) (set (hour time) num)] - [(#\M) (set (minute time) num)] - [(#\S) (set (second time) num)] - [(#\m) (set (month date) num)] - [(#\d) (set (day date) num)]))))] + (let ((lens + (case (cadr fmt) + [(#\H) (lens-compose datetime-time hour)] + [(#\M) (lens-compose datetime-time minute)] + [(#\S) (lens-compose datetime-time second)] + [(#\m) (lens-compose datetime-date month)] + [(#\d) (lens-compose datetime-date day)]))) + (set dt lens num))))] [(#\Y) (let* ((pre post (span-upto 4 char-numeric? str)) @@ -878,7 +826,7 @@ Returns -1 on failure" (loop post (cddr fmt) - (as-dt (set (year date) num))))] + (set dt datetime-date year num)))] [else (err "Unimplemented or incorrect parse token ~S" str)])] [else @@ -894,11 +842,11 @@ Returns -1 on failure" (define* (string->time str optional: (fmt "~H:~M:~S") (locale %global-locale) key: return-trailing) - (get-time% (string->datetime str fmt locale return-trailing: return-trailing))) + (datetime-time (string->datetime str fmt locale return-trailing: return-trailing))) (define* (string->date str optional: (fmt "~Y-~m-~d") (locale %global-locale) key: return-trailing) - (get-date (string->datetime str fmt locale return-trailing: return-trailing))) + (datetime-date (string->datetime str fmt locale return-trailing: return-trailing))) ;; Parse @var{string} as either a date, time, or date-time. ;; String MUST be on iso-8601 format. @@ -924,7 +872,7 @@ Returns -1 on failure" (let ((dt (string->datetime str "~Y~m~dT~H~M~S~Z"))) (if (tz dt) dt - (set (tz dt) zone)))) + (tz dt zone)))) (define (parse-iso-date str) (string->date str)) @@ -949,8 +897,8 @@ Returns -1 on failure" second: ,(second t))) (define* (datetime->sexp dt optional: verbose) - `(datetime date: ,(if verbose (date->sexp (get-date dt)) (get-date dt)) - time: ,(if verbose (time->sexp (get-time% dt)) (get-time% dt)) + `(datetime date: ,(if verbose (date->sexp (datetime-date dt)) (datetime-date dt)) + time: ,(if verbose (time->sexp (datetime-time dt)) (datetime-time dt)) tz: ,(tz dt))) @@ -992,8 +940,8 @@ Returns -1 on failure" (define (datetime= . args) (reduce (lambda (a b) - (and (date= (get-date a) (get-date b)) - (time= (get-time% a) (get-time% b)) + (and (date= (datetime-date a) (datetime-date b)) + (time= (datetime-time a) (datetime-time b)) a)) #t args)) @@ -1053,16 +1001,16 @@ Returns -1 on failure" (define datetime< (fold-comparator (lambda (a b) - (if (date= (get-date a) (get-date b)) - (time< (get-time% a) (get-time% b)) - (date< (get-date a) (get-date b)))))) + (if (date= (datetime-date a) (datetime-date b)) + (time< (datetime-time a) (datetime-time b)) + (date< (datetime-date a) (datetime-date b)))))) (define datetime<= (fold-comparator (lambda (a b) - (if (date= (get-date a) (get-date b)) - (time<= (get-time% a) (get-time% b)) - (date<= (get-date a) (get-date b)))))) + (if (date= (datetime-date a) (datetime-date b)) + (time<= (datetime-time a) (datetime-time b)) + (date<= (datetime-date a) (datetime-date b)))))) (define date/-time< (fold-comparator @@ -1126,19 +1074,20 @@ Returns -1 on failure" (let loop ((target base) (change change)) (if (>= (days-in-month target) (+ (day change) (day target))) ;; No date overflow, just add the change - (values (set-> target (day = (+ (day change)))) - (set-> change (day 0))) + (values (-> target (day (+ (day target) + (day change)))) + (day change 0)) ;; Date (and possibly year) overflow (loop (if (= 12 (month target)) - (set-> target - (year = (+ 1)) - (month 1) - (day 1)) - (set-> target - (month = (+ 1)) - (day 1))) - (set-> change - (day = (- (1+ (- (days-in-month target) (day target)))))))))) + (-> (modify target year 1+) + (month 1) + (day 1)) + (-> (modify target month 1+) + (day 1))) + (modify change day - + (- (day target)) + (days-in-month target) + 1))))) (define-values (month-fixed change**) (if (date-zero? change*) @@ -1146,20 +1095,19 @@ Returns -1 on failure" (let loop ((target days-fixed) (change change*)) (if (< 12 (+ (month change) (month target))) ;; if we overflow into the next year - (loop (set-> target - (year = (+ 1)) - (month 1)) - (set (month change) = (- (- 13 (month target))))) - + (loop (-> (modify target year 1+) + (month 1)) + (modify change month + + (month target) -13)) ;; if we don't overflow our date - (values (set (month target) = (+ (month change))) - (set (month change) 0)) + (values (modify target month + (month change)) + (month change 0)) )))) ;; change** should here should have both month and date = 0 - (set (year month-fixed) = (+ (year change**)))) + (year month-fixed (+ (year month-fixed) (year change**)))) (define (date+% change base) @@ -1188,33 +1136,30 @@ Returns -1 on failure" (define-values (days-fixed change*) (let loop ((target base) (change change)) (if (>= (day change) (day target)) - (let ((new-change (set (day change) = (- (day target))))) + (let ((new-change (modify change day - (day target)))) (loop (if (= 1 (month target)) - (set-> target - (year = (- 1)) - (month 12) - (day 31) ; days in december - ) - (set-> target - (month = (- 1)) - (day (days-in-month (set (month target) = (- 1)))))) + (-> (modify target year 1-) + (month 12) + (day 31) ; days in december + ) + (let ((nm (modify target month 1-))) + (day nm (days-in-month nm)))) new-change)) - (values (set (day target) = (- (day change))) - (set (day change) 0))))) + (values (modify target day - (day change)) + (day change 0))))) (define-values (month-fixed change**) (let loop ((target days-fixed) (change change*)) (if (>= (month change) (month target)) - (loop (set-> target - (year = (- 1)) - (month 12)) - (set (month change) = (- (month target)))) - (values (set (month target) = (- (month change))) - (set (month change) 0))))) + (loop (-> (modify target year 1-) + (month 12)) + (modify change month - (month target))) + (values (modify target month - (month change)) + (month change 0))))) ;; change** should here should have both month and date = 0 - (set (year month-fixed) = (- (year change**)))) + (modify month-fixed year - (year change**))) (define (date-% change base) @@ -1248,28 +1193,28 @@ Returns -1 on failure" ;; while (day base) > (days-in-month base) ;; month++; days -= (days-in-month base) (define second-fixed - (let loop ((target (set (second base) = (+ (second change))))) + (let loop ((target (modify base second + (second change)))) (if (>= (second target) 60) - (loop (set-> target - (minute = (+ 1)) - (second = (- 60)))) + (loop (-> target + (modify minute 1+) + (modify second - 60))) target))) ;; while (month base) > 12 ;; year++; month -= 12 (define minute-fixed - (let loop ((target (set (minute second-fixed) = (+ (minute change))))) + (let loop ((target (modify second-fixed minute + (minute change)))) (if (>= (minute target) 60) - (loop (set-> target - (hour = (+ 1)) - (minute = (- 60)))) + (loop (-> target + (modify hour 1+) + (modify minute - 60))) target))) - (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change)))) + (define hour-almost-fixed (modify minute-fixed hour + (hour change))) (if (<= 24 (hour hour-almost-fixed)) (let ((div remainder (floor/ (hour hour-almost-fixed) 24))) - (values (set (hour hour-almost-fixed) remainder) div)) + (values (hour hour-almost-fixed remainder) div)) (values hour-almost-fixed 0))) ;;; PLUS @@ -1289,28 +1234,26 @@ Returns -1 on failure" (define-values (second-fixed change*) (let loop ((target base) (change change)) (if (> (second change) (second target)) - (loop (set-> target - (minute = (- 1)) - (second 60)) - (set (second change) = (- (second target)))) - (values (set (second target) = (- (second change))) - (set (second change) 0))))) + (loop (-> (modify target minute 1-) + (second 60)) + (modify change second - (second target))) + (values (modify target second - (second change)) + (second change 0))))) (define-values (minute-fixed change**) (let loop ((target second-fixed) (change change*)) (if (> (minute change) (minute target)) - (loop (set-> target - (hour = (- 1)) - (minute 60)) - (set (minute change) = (- (minute target)))) - (values (set (minute target) = (- (minute change))) - (set (minute change) 0))))) + (loop (-> (modify target hour 1-) + (minute 60)) + (modify change minute - (minute target))) + (values (modify target minute - (minute change)) + (minute change 0))))) (if (>= (hour minute-fixed) (hour change**)) - (values (set (hour minute-fixed) = (- (hour change**))) 0) + (values (modify minute-fixed hour - (hour change**)) 0) (let ((diff (- (hour minute-fixed) (hour change**)))) - (values (set (hour minute-fixed) (modulo diff 24)) + (values (hour minute-fixed (modulo diff 24)) (abs (floor (/ diff 24))))))) ;; Goes backwards from base, returning the two values: @@ -1331,21 +1274,20 @@ Returns -1 on failure" (define (datetime+ base change) - (let ((time overflow (time+ (get-time% base) (get-time% change)))) - (datetime date: (date+ (get-date base) - (get-date change) - (date day: overflow)) - time: time - tz: (get-timezone base) - ))) + (let ((time* overflow (time+ (datetime-time base) (datetime-time change)))) + (-> base + (modify datetime-date date+ + (datetime-date change) + (date day: overflow)) + (datetime-time time*)))) (define (datetime- base change) - (let ((time underflow (time- (get-time% base) (get-time% change)))) - (datetime date: (date- (get-date base) - (get-date change) - (date day: underflow)) - time: time - tz: (tz base)))) + (let ((time* underflow (time- (datetime-time base) (datetime-time change)))) + (-> base + (modify datetime-date date- + (datetime-date change) + (date day: underflow)) + (datetime-time time*)))) ;;; the *-difference procedures takes two actual datetimes. ;;; date- instead takes a date and a delta (but NOT an actual date). @@ -1357,20 +1299,18 @@ Returns -1 on failure" (define-values (b* a*) (let loop ((b b) (a a)) (if (> (day a) (day b)) - (let ((new-a (set (day a) = (- (1+ (day b)))))) + (let ((new-a (day a (- (day a) (day b) 1)))) (loop (if (= 0 (month b)) - (set-> b - (year = (- 1)) - (month 11) - (day 30) ; Last day in december - ) - (set-> b - (month = (- 1)) - (day (1- (days-in-month b))))) ; last in prev month + (-> (modify b year 1-) + (month 11) + (day 30) ; Last day in december + ) + (-> (modify b month 1-) + (day (1- (days-in-month b))))) ; last in prev month new-a)) ;; elif (> (day b) (day a)) - (values (set (day b) = (- (day a))) - (set (day a) 0))))) + (values (day b (- (day b) (day a))) + (day a 0))))) ;; (day a*) should be 0 here. @@ -1378,17 +1318,16 @@ Returns -1 on failure" (define-values (b** a**) (let loop ((b b*) (a a*)) (if (> (month a) (month b)) - (loop (set-> b - (year = (- 1)) - (month 11)) - (set (month a) = (- (1+ (month b))))) + (loop (-> (modify b year 1-) + (month 11)) + (modify a month - 1 (month b))) ;; elif (> (month b) (month a)) - (values (set (month b) = (- (month a))) - (set (month a) 0))))) + (values (modify b month - (month a)) + (month a 0))))) ;; a** should here should have both month and date = 0 - (set (year b**) = (- (year a**)))) + (year b** (- (year b**) (year a**)))) @@ -1407,20 +1346,21 @@ Returns -1 on failure" (list earlier-date later-date) #f)) - (date-difference% (set-> later-date - (month = (- 1)) - (day = (- 1))) - (set-> earlier-date - (month = (- 1)) - (day = (- 1))))) + (let ((proc (lambda (d) (-> d + (modify month 1-) + (modify day 1-))))) + (date-difference% (proc later-date) + (proc earlier-date)))) ;; NOTE, this is only properly defined when end is greater than start. (define (datetime-difference end start) ;; NOTE Makes both start and end datetimes in the current local time. - (let ((fixed-time overflow (time- (get-time% end) - (get-time% start)))) - (datetime date: (date-difference (date- (get-date end) + (let ((fixed-time overflow (time- (datetime-time end) + (datetime-time start)))) + (datetime date: (date-difference (date- (datetime-date end) (date day: overflow)) - (get-date start)) - time: fixed-time))) + (datetime-date start)) + time: fixed-time + ;; TODO TZ + ))) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 470f6c07..acfb17a8 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -342,17 +342,17 @@ (datetime date: (match (rule-on rule) - ((? number? on) (set (day d) on)) + ((? number? on) (day d on)) (('last n) (iterate (lambda (d) (date- d (date day: 1))) (lambda (d) (eqv? n (week-day d))) - (set (day d) (days-in-month d)))) + (day d (days-in-month d)))) (((? (lambda (x) (memv x '(< >))) <>) wday base-day) (iterate (lambda (d) ((if (eq? '< <>) date- date+) d (date day: 1))) (lambda (d) (eqv? wday (week-day d))) - (set (day d) base-day)))) + (day d base-day)))) tz: (case (timespec-type (rule-at rule)) ((#\w) #f) ((#\s) (warning (G_ "what even is \"Standard time\"‽")) #f) diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm index b82aa6d0..3bed2a5e 100644 --- a/module/hnh/module-introspection/module-uses.scm +++ b/module/hnh/module-introspection/module-uses.scm @@ -82,6 +82,8 @@ (_ '()))) ;; find all use-modules forms, and return what they pull in +;; NOTE this will pull in all forms looking like a (use-modules ...) +;; form, even if they are quoted, or in a cond-expand (define (module-use-module-uses forms) (match forms (('use-modules modules ...) diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm new file mode 100644 index 00000000..384afd4b --- /dev/null +++ b/module/hnh/test/testrunner.scm @@ -0,0 +1,126 @@ +(define-module (hnh test testrunner) + :use-module (srfi srfi-64) + :use-module (hnh test util) + :use-module (ice-9 pretty-print) + :use-module (ice-9 format) + :export (verbose? construct-test-runner) + ) + +(define verbose? (make-parameter #f)) + +(define (pp form indent prefix-1) + (let ((prefix (make-string (+ (string-length indent) + (string-length prefix-1)) + #\space))) + (string-replace-head + (with-output-to-string + (lambda () (pretty-print + form + display?: #t + per-line-prefix: prefix + width: (- 79 (string-length indent))))) + (string-append indent prefix-1)))) + + +(define (construct-test-runner) + (define runner (test-runner-null)) + (define depth 0) + ;; end of individual test case + (test-runner-on-test-begin! runner + (lambda (runner) + (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) + (test-runner-on-test-end! runner + (lambda (runner) + (when (verbose?) (display (make-indent depth))) + (case (test-result-kind runner) + ((pass) (display (green "X"))) + ((fail) (display (red "E"))) + ((xpass) (display (yellow "X"))) + ((xfail) (display (yellow "E"))) + ((skip) (display (yellow "-")))) + (when (or (verbose?) (eq? 'fail (test-result-kind))) + (format #t " ~a~%" + (cond ((test-runner-test-name runner) + (negate string-null?) => identity) + ((test-result-ref runner 'expected-value) + => (lambda (p) (with-output-to-string + (lambda () + (display (bold "[SOURCE]: ")) + (truncated-print p width: 60)))))))) + (when (eq? 'fail (test-result-kind)) + (cond ((test-result-ref runner 'actual-error) + => (lambda (err) + (if (and (list? err) + (= 5 (length err))) + (let ((err (list-ref err 0)) + (proc (list-ref err 1)) + (fmt (list-ref err 2)) + (args (list-ref err 3))) + (format #t "~a~a in ~a: ~?~%" + (make-indent (1+ depth)) + err proc fmt args)) + (format #t "~aError: ~s~%" (make-indent (1+ depth)) err)))) + (else + (let ((unknown-expected (gensym)) + (unknown-actual (gensym))) + (let ((expected (test-result-ref runner 'expected-value unknown-expected)) + (actual (test-result-ref runner 'actual-value unknown-actual))) + (let ((indent (make-indent (1+ depth)))) + (if (eq? expected unknown-expected) + (format #t "~aAssertion failed~%" indent) + (begin + (display (pp expected indent "Expected: ")) + (display (pp actual indent "Received: ")) + (let ((d (diff (pp expected "" "") + (pp actual "" "")))) + (display + (string-join + (map (lambda (line) (string-append indent "|" line)) + (string-split d #\newline)) + "\n" 'suffix)))))))))) + (format #t "~aNear ~a:~a~%" + (make-indent (1+ depth)) + (test-result-ref runner 'source-file) + (test-result-ref runner 'source-line)) + (pretty-print (test-result-ref runner 'source-form) + (current-output-port) + per-line-prefix: (string-append (make-indent (1+ depth)) "> ") + )) + + (let ((start (test-runner-aux-value runner)) + (end (transform-time-of-day (gettimeofday)))) + (when (< (µs 1) (- end start)) + (format #t "~%Slow test: ~s, took ~a~%" + (test-runner-test-name runner) + (exact->inexact (/ (- end start) (µs 1))) + ))))) + + ;; on start of group + (test-runner-on-group-begin! runner + ;; count is number of #f + (lambda (runner name count) + (if (<= depth 1) + (format #t "~a ~a ~a~%" + (make-string 10 #\=) + name + (make-string 10 #\=)) + (when (verbose?) + (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) + (set! depth (1+ depth)))) + (test-runner-on-group-end! runner + (lambda (runner) + (set! depth (1- depth)) + (when (<= depth 1) + (newline)))) + ;; after everything else is done + (test-runner-on-final! runner + (lambda (runner) + (format #t "Guile version ~a~%~%" (version)) + (format #t "pass: ~a~%" (test-runner-pass-count runner)) + (format #t "fail: ~a~%" (test-runner-fail-count runner)) + (format #t "xpass: ~a~%" (test-runner-xpass-count runner)) + (format #t "xfail: ~a~%" (test-runner-xfail-count runner)) + )) + + runner) + diff --git a/module/hnh/test/util.scm b/module/hnh/test/util.scm new file mode 100644 index 00000000..3d51e162 --- /dev/null +++ b/module/hnh/test/util.scm @@ -0,0 +1,57 @@ +(define-module (hnh test util) + :use-module ((hnh util) :select (begin1)) + :use-module ((hnh util io) :select (call-with-tmpfile)) + :use-module (ice-9 pretty-print) + :use-module ((ice-9 rdelim) :select (read-string)) + :use-module ((ice-9 popen) + :select (open-pipe* + close-pipe)) + :export (µs + transform-time-of-day + green + red + yellow + bold + make-indent + string-replace-head + diff + )) + +(define (µs x) + (* x #e1e6)) + +(define (transform-time-of-day tod) + (+ (* (µs 1) (car tod)) + (cdr tod))) + +(define (escaped sequence string) + (format #f "\x1b[~am~a\x1b[m" sequence string)) + +;; Terminal output formatting. Doesn NOT compose +(define (green s) (escaped 32 s)) +(define (red s) (escaped 31 s)) +(define (yellow s) (escaped 33 s)) +(define (bold s) (escaped 1 s)) + +(define (make-indent depth) + (make-string (* 2 depth) #\space)) + +(define (string-replace-head s1 s2) + (string-replace s1 s2 + 0 (string-length s2))) + + +(define diff-cmd + ;; '("diff") + '("git" "diff" "--no-index" "--color-moved=default" "--color=always"; "--word-diff=color" + ) + ) + +(define (diff s1 s2) + (let ((filename1 (call-with-tmpfile (lambda (p f) (pretty-print s1 p display?: #t) f))) + (filename2 (call-with-tmpfile (lambda (p f) (pretty-print s2 p display?: #t) f)))) + (let ((pipe (apply open-pipe* + OPEN_READ + (append diff-cmd (list filename1 filename2))))) + (begin1 (read-string pipe) + (close-pipe pipe))))) diff --git a/module/hnh/test/xmllint.scm b/module/hnh/test/xmllint.scm new file mode 100644 index 00000000..95362607 --- /dev/null +++ b/module/hnh/test/xmllint.scm @@ -0,0 +1,27 @@ +(define-module (hnh test xmllint) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((rnrs io ports) :select (get-string-all)) + :use-module ((hnh util) :select (begin1)) + :export (xmllint) + ) + + +(define (xmllint str) + (let ((in* out (car+cdr (pipe))) + (in out* (car+cdr (pipe))) + (cmdline (string-split "xmllint --format -" #\space))) + (define pid + (spawn (car cmdline) cmdline + input: in* + output: out*)) + (close-port in*) + (close-port out*) + + (display str out) + (force-output out) + (close-port out) + + (begin1 (get-string-all in) + (close-port in)))) diff --git a/module/hnh/util.scm b/module/hnh/util.scm index 91c081e2..9f71c1ec 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -18,6 +18,7 @@ find-extreme find-min find-max filter-sorted != + init+last take-to string-take-to string-first @@ -70,6 +71,10 @@ :replace (set! define-syntax when unless)) +(cond-expand + (guile-3 (use-modules ((ice-9 copy-tree) :select (copy-tree)))) + (else)) + ((@ (guile) define-syntax) define-syntax (syntax-rules () ((_ (name args ...) body ...) @@ -179,9 +184,12 @@ +;; TODO this is called flip in Haskell land (define (swap f) (lambda args (apply f (reverse args)))) - +;; Swap would be +;; (define (swap p) +;; (xcons (car p) (cdr p))) ;; Allow set to work on multiple values at once, ;; similar to Common Lisp's @var{setf} @@ -282,6 +290,12 @@ ;; (define (!= a b) (not (= a b))) (define != (negate =)) + +(define (init+last l) + (let ((last rest (car+cdr (reverse l)))) + (values (reverse rest) last))) + + (define (take-to lst i) "Like @var{take}, but might lists shorter than length." (if (> i (length lst)) @@ -425,7 +439,7 @@ (reverse (cons (map list last) rest )))))) ;; Given an arbitary tree, do a pre-order traversal, appending all strings. -;; non-strings allso allowed, converted to strings and also appended. +;; non-strings also allowed, converted to strings and also appended. (define (string-flatten tree) (cond [(string? tree) tree] [(list? tree) (string-concatenate (map string-flatten tree))] diff --git a/module/hnh/util/assert.scm b/module/hnh/util/assert.scm new file mode 100644 index 00000000..74715654 --- /dev/null +++ b/module/hnh/util/assert.scm @@ -0,0 +1,9 @@ +(define-module (hnh util assert) + :use-module (rnrs base) + :export (assert*) + ) + +(define-syntax assert* + (syntax-rules () + ((_ assertion) + (assert assertion)))) diff --git a/module/hnh/util/env.scm b/module/hnh/util/env.scm index bb42d966..f5992245 100644 --- a/module/hnh/util/env.scm +++ b/module/hnh/util/env.scm @@ -1,5 +1,7 @@ (define-module (hnh util env) - :export (let-env with-working-directory)) + :export (let-env + with-working-directory + with-locale1)) (define-syntax let-env (syntax-rules () @@ -37,3 +39,12 @@ thunk (lambda () (chdir old-cwd))))) + +(define-syntax-rule (with-locale1 category locale thunk) + (let ((old #f)) + (dynamic-wind + (lambda () + (set! old (setlocale category)) + (setlocale category locale)) + thunk + (lambda () (setlocale category old))))) diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm index d73a1de8..09900f8d 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -5,7 +5,8 @@ open-output-port read-lines with-atomic-output-to-file - call-with-tmpfile)) + call-with-tmpfile + ->port)) (define (open-input-port str) (if (string=? "-" str) @@ -72,3 +73,10 @@ (begin1 (proc port filename) (close-port port)))))) + +(define (->port port-or-string) + (cond ((port? port-or-string) port-or-string) + ((string? port-or-string) (open-input-string port-or-string)) + (else (scm-error 'misc-error "->port" + "Not a port or string" + (list port-or-string) #f)))) diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm new file mode 100644 index 00000000..26c75be7 --- /dev/null +++ b/module/hnh/util/lens.scm @@ -0,0 +1,105 @@ +(define-module (hnh util lens) + :use-module (srfi srfi-1) + :export (modify + modify* + set + get + + identity-lens + compose-lenses + lens-compose + + ref car* cdr* + + each)) + + +(define (modify object lens f . args) + (lens object (apply f (lens object) args))) + +(define-syntax modify* + (syntax-rules () + ((_ object f) (f object)) + ((_ object lens rest ...) + (modify object lens + (lambda (object*) (modify* object* rest ...)))))) + +;; The simple case of getting and setting when you already have the lens is trivial +;; (lens object) +;; (lens object new-value) + +(define-syntax set + (syntax-rules () + ((_ object lenses ... value) + (modify* object lenses ... (const value))))) + +(define-syntax get + (syntax-rules () + ((_ object) object) + ((_ object f lenses ...) + (get (f object) lenses ...)))) + + + + +(define (make-lens getter setter) + (case-lambda ((datum) (getter datum)) + ((datum new-value) (setter datum new-value)))) + +(define-syntax build-lens + (syntax-rules () + ((_ (getter gargs ...) + (setter sargs ...)) + ;; (make-lens (lambda (datum) (getter datum gargs ...)) + ;; (lambda (datum new-value) (setter datum sargs ... new-value))) + (case-lambda ((datum) + (getter datum gargs ...)) + ((datum new-value) + (setter datum sargs ... new-value)))) + ((_ (getter args ...) setter) + (build-accesor (getter args ...) (setter))) + ((_ getter (setter args ...)) + (build-lens (getter) (setter args ...))) + ((_ getter setter) + (build-lens (getter) (setter))))) + + + + +(define identity-lens + (case-lambda ((a) a) + ((_ a) a))) + +(define (compose-lenses% f g) + (build-lens (get f g) (set f g))) + +(define (compose-lenses . fs) + (reduce-right compose-lenses% identity-lens fs)) + +(define lens-compose compose-lenses) + + + +(define (list-change list index value) + (cond ((zero? index) + (cons value (cdr list))) + ((null? list) + (scm-error 'out-of-range "list-change" "" #f #f)) + (else + (cons (car list) + (list-change (cdr list) + (1- index) + value))))) + + + +(define (ref idx) + (build-lens (list-ref idx) (list-change idx))) + + +(define car* (make-lens car (lambda (pair value) (cons value (cdr pair))))) +(define cdr* (make-lens cdr (lambda (pair value) (cons (car pair) value)))) + +(define (each obj lens proc) + (modify obj lens + (lambda (lst) (map proc lst)))) diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm new file mode 100644 index 00000000..4477b462 --- /dev/null +++ b/module/hnh/util/object.scm @@ -0,0 +1,169 @@ +(define-module (hnh util object) + :use-module (srfi srfi-9 gnu) + :use-module (ice-9 curried-definitions) + :use-module (hnh util) + :use-module (hnh util type) + :export (define-type)) + + + +;; If given a syntax list extract the first lexeme, if given a "symbol", return that. +(define (syntax-first stx) + (syntax-case stx () + ((a rest ...) #'a) + (a #'a))) + +(define (construct-syntax stx base transform) + (->> base + syntax->datum + (format #f transform) + string->symbol + (datum->syntax stx))) + +;; stx should be a syntax object of a key-value list on the form +;; (key: value key2: value2) +;; and target-key the datum which the target key unwraps to. +;; returns the corresponding values syntax +;; or #f if none is found +(define (kv-ref stx target-key) + (syntax-case stx () + ((key value rest ...) + (if (eqv? target-key (syntax->datum #'key)) + #'value + (kv-ref #'(rest ...) target-key))) + (_ #f))) + + + +;; Given (x type: predicate?), expand to a single `unless' form (otherwise #f) +(define-syntax (validator stx) + (syntax-case stx () + ((_ (name kvs ...)) + (cond ((kv-ref #'(kvs ...) type:) + => (lambda (type-stx) + (with-syntax ((type type-stx)) + #'(unless (build-validator-body name type) + (scm-error 'wrong-type-arg "validator" + "Invalid value for `~s'. Expected ~s, got ~s" + (list (quote name) (quote type) name) #f))))) + (else #f))) + ((_ name) #f))) + + + + +;; Get syntax for getter-procedure's symbol +(define-syntax (field-get stx) + (syntax-case stx () + ;; ((_ (name kv ...)) #'(field-get name)) + ((_ type-name name) + (->> + (format #f "~a-~a-get" + (syntax->datum #'type-name) + (syntax->datum #'name)) + string->symbol + (datum->syntax stx))))) + +;; get syntax for setter-procedure's symbol +(define-syntax (field-set stx) + (syntax-case stx () + ;; ((_ (name kv ...)) #'(field-set name)) + ((_ type-name name) + (->> + (format #f "~a-~a-set" + (syntax->datum #'type-name) + (syntax->datum #'name)) + string->symbol + (datum->syntax stx))))) + +;; Construct a field line for define-immutable-record-type +(define ((field-declaration type) stx) + (syntax-case stx () + (name + (with-syntax ((name-get (->> (format #f "~a-~a-get" + (syntax->datum type) + (syntax->datum #'name)) + string->symbol + (datum->syntax stx))) + (name-set (->> (format #f "~a-~a-set" + (syntax->datum type) + (syntax->datum #'name)) + string->symbol + (datum->syntax stx)))) + #'(name name-get name-set))))) + +;; Accessors are procedures for getting and setting fields in records +(define-syntax (build-accessor stx) + (syntax-case stx () + ((_ type-name (name kvs ...)) + #'(define name + (case-lambda ((datum) + ((field-get type-name name) datum)) + ((datum new-value) + ;; validator uses the first field (in the list) as both + ;; the name of the field, and a reference to the value of + ;; the field. This ensures those two are the same for validator, + ;; while keeping name bound to the accessor in the outer scope. + (let ((name new-value)) + (validator (name kvs ...))) + ((field-set type-name name) datum new-value))))) + ((_ type-name name) #'(build-accessor type-name (name))))) + + +;; Go from my concept of field deffinitions, to what lambda* wants as arguments +(define (lambda*-stx field) + (syntax-case field () + ((name kvs ...) + (cond ((kv-ref #'(kvs ...) default:) + => (lambda (dflt) #`(name #,dflt))) + (else #'name))) + (name #'name))) + + + +(define-syntax (define-type stx) + (syntax-case stx () + ((_ (name attribute ...) field ...) + ;; These names SHOULD leak + (with-syntax ((<type>? (construct-syntax stx #'name "~a?"))) + ;; These names are manually constructed, since generated identifiers are + ;; only dependant on the source from which they orginate, which leads to + ;; multiple instances of <type> being equal for similar types... + ;; See the manual 6.10.10 Hygiene and the Top-Level + (with-syntax ((<type> (construct-syntax stx #'name "<~a>")) + (make-<type> (construct-syntax stx #'name "make-~a%"))) + #`(begin + (define-immutable-record-type <type> + (make-<type> #,@(map syntax-first #'(field ...))) + <type>? + #,@(map (field-declaration #'name) + (map syntax-first #'(field ...)))) + + ;; User-facing constructor + (define name + #,(cond ((kv-ref #'(attribute ...) constructor:) + => (lambda (constructor-builder) + #`(#,constructor-builder + ;; primitive constructor + make-<type> + ;; Type validator + (lambda #,(map syntax-first #'(field ...)) + (validator field) ...)))) + (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...))) + ;; Type validators + (validator field) ... + (make-<type> #,@(map syntax-first #'(field ...))))))) + + ;; Field accessors + (build-accessor name field) ... + + ;; if printer in attribute + #,@(cond ((kv-ref #'(attribute ...) printer:) + => (lambda (printer) + (list #`(set-record-type-printer! <type> #,printer)))) + (else '())))))) + + ;; else, type name without extra attributes + #; + ((_ name field ...) + #'(define-type (name) field ...)))) diff --git a/module/hnh/util/set.scm b/module/hnh/util/set.scm new file mode 100644 index 00000000..2839a231 --- /dev/null +++ b/module/hnh/util/set.scm @@ -0,0 +1,46 @@ +(define-module (hnh util set) + :use-module (hnh util object) + :use-module (hnh util table)) + +(define-type (set) + (set-data default: (make-table))) + +(define (set-null) (set)) + +(define (set-adjoin value set) + (modify set set-data tree-put value #t)) + +(define (set-disjoin value set) + (modify set set-data tree-put value #f)) + +(define (in-set? set value) + (catch 'out-of-range + (lambda () (tree-get (set-data set) value)) + (lambda () #f))) + +(define (set-fold f done set) + (tree-fold (lambda (k v lst) + (if v + (f k done) + done)) + done set)) + +(define (set->list set) + (set-fold cons '() set)) + +(define (set-union set1 set2) + (set-fold set-adjoin set1 set2)) + +(define (set-intersection set1 set2) + (set-fold (lambda (v set) + (if (in-set? v set1) + set1 + (set-disjoin v set1))) + set1 set2)) + +(define (set-difference set1 set2) + (set-fold set-disjoin set1 set2)) + +;; (define (set-xor set1 set2)) + + diff --git a/module/hnh/util/state-monad.scm b/module/hnh/util/state-monad.scm new file mode 100644 index 00000000..91201583 --- /dev/null +++ b/module/hnh/util/state-monad.scm @@ -0,0 +1,120 @@ +;;; Commentary: +;;; A state monad similar to (and directly influenced by) the one found in in +;;; Haskell +;;; Each procedure can either explicitly take the state as a curried last +;;; argument, or use the `do' notation, which handles that implicitly. +;;; Each procedure MUST return two values, where the second value is the state +;;; value which will be chained. +;;; +;;; Code borrowed from guile-dns +;;; Code: + +(define-module (hnh util state-monad) + :use-module (ice-9 curried-definitions) + :replace (do mod) + :export (with-temp-state + <$> return get get* put put* sequence lift + eval-state exec-state)) + +(define-syntax do + (syntax-rules (<- let =) + ((_ (a ...) <- b rest ...) + (lambda state-args + (call-with-values (lambda () (apply b state-args)) + (lambda (a* . next-state) + (apply (lambda (a ...) + (apply (do rest ...) + next-state)) + a*))))) + ((_ a <- b rest ...) + (lambda state-args + (call-with-values (lambda () (apply b state-args)) + (lambda (a . next-state) + (apply (do rest ...) + next-state))))) + + ((_ a = b rest ...) + (let ((a b)) + (do rest ...))) + + ((_ a) + (lambda state (apply a state))) + ((_ a rest ...) + (lambda state + (call-with-values (lambda () (apply a state)) + (lambda (_ . next-state) + (apply (do rest ...) + next-state))))))) + + +(define (with-temp-state state* op) + (do old <- (get*) + (apply put* state*) + ret-value <- op + (apply put* old) + (return ret-value))) + + +(define (<$> f y) + (do tmp <- y + (return (f tmp)))) + +(define ((return x) . y) + (apply values x y)) + +(define ((get*) . state) + "Like @code{get}, but always returns a list" + (values state state)) + +(define ((get) fst . state) + "If state contains a single variable return that, otherwise, return a list of all variables in state" + (if (null? state) + (values fst fst) + (apply values (cons fst state) fst state))) + +(define ((put . new-state) fst . old-state) + (if (null? old-state) + (apply values fst new-state) + (apply values (cons fst old-state) new-state))) + +;; Like put, but doesn't return anything (useful) +(define ((put* . new-state) . _) + (apply values #f new-state)) + +(define (mod proc) + (do + a <- (get) + (put (proc a)))) + +;; ms must be a list of continuations +(define (sequence ms) + (if (null? ms) + (return '()) + (do + fst <- (car ms) + rest <- (sequence (cdr ms)) + (return (cons fst rest))))) + + +(define (lift proc . arguments) + (do xs <- (sequence arguments) + (return (apply proc xs)))) + + +;; Run state, returning value +(define (eval-state st init) + (call-with-values + (lambda () + (if (procedure? init) + (call-with-values init st) + (st init))) + (lambda (r . _) r))) + +;; Run state, returning state +(define (exec-state st init) + (call-with-values + (lambda () + (if (procedure? init) + (call-with-values init st) + (st init))) + (lambda (_ . v) (apply values v)))) diff --git a/module/hnh/util/table.scm b/module/hnh/util/table.scm new file mode 100644 index 00000000..a57e6591 --- /dev/null +++ b/module/hnh/util/table.scm @@ -0,0 +1,108 @@ +(define-module (hnh util table) + :use-module (srfi srfi-1) + :use-module (srfi srfi-88) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (hnh util lens) + :use-module (hnh util object) + :export ((make-tree . table) + (tree-get . table-get) + (tree-put . table-put) + (tree-remove . table-remove) + (tree->list . table->list) + (tree? . table?) + (alist->tree . alist->table))) + +(define (symbol<? . args) + (apply string<? (map symbol->string args))) + +(define-syntax-rule (symbol< args ...) + (string< (symbol->string args) ...)) + +(define-type (tree-node) + (key type: symbol?) + value + (left type: tree? default: (tree-terminal)) + (right type: tree? default: (tree-terminal))) + +;; Type tagged null +(define-type (tree-terminal)) + +;; Wrapped for better error messages +(define (make-tree) (tree-terminal)) + +(define (tree? x) + (or (tree-node? x) + (tree-terminal? x))) + +(define (tree-put tree k v) + (cond ((tree-terminal? tree) (tree-node key: k value: v)) + ((eq? k (key tree)) (value tree v)) + (else + (modify tree (if (symbol<? k (key tree)) left right) + tree-put k v)))) + +(define (tree-get tree k) + (cond ((tree-terminal? tree) #f ; (throw 'out-of-range) + ) + ((eq? k (key tree)) (value tree)) + ((symbol<? k (key tree)) + (tree-get (left tree) k)) + (else + (tree-get (right tree) k)))) + +(define (tree-remove tree k) + (cond ((tree-terminal? tree) tree) + ((eq? k (key tree)) + (merge-trees (left tree) (right tree))) + ((symbol<? k (key tree)) + (modify tree left (lambda (t) (tree-remove t k)))) + (else + (modify tree right (lambda (t) (tree-remove t k)))))) + +(define (merge-trees a b) + ;; TODO write a better version of this + (fold (lambda (item tree) + (apply tree-put tree item)) + a + b)) + +;; in-order traversal +(define (tree->list tree) + (if (tree-terminal? tree) + '() + (append (tree->list (left tree)) + (list (cons (key tree) (value tree))) + (tree->list (right tree))))) + +;; undefined order, probably pre-order +(define (tree-map f tree) + (if (tree-terminal? tree) + '() + (tree-node key: (key tree) + value: (f (key tree) (value tree)) + left: (tree-map f (left tree)) + right: (tree-map f (right tree))))) + +;; pre-order +(define (tree-fold f init tree) + (if (tree-terminal? tree) + init + (let ((a (f (key tree) (value tree) init))) + (let ((b (tree-fold f a (left tree)))) + (tree-fold f b (right tree)))))) + +(define (alist->tree alist) + (fold (lambda (kv tree) (tree-put tree (car kv) (cdr kv))) + (tree-terminal) + alist)) + + + +(define (make-indent depth) (make-string (* 2 depth) #\space)) + +(define* (print-tree tree optional: (depth 0)) + (unless (tree-terminal? tree) + (format #t "~a- ~s: ~s~%" (make-indent depth) (key tree) (value tree)) + (print-tree (left tree) (1+ depth)) + (print-tree (right tree) (1+ depth)))) diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm new file mode 100644 index 00000000..800834e5 --- /dev/null +++ b/module/hnh/util/type.scm @@ -0,0 +1,46 @@ +(define-module (hnh util type) + :use-module ((srfi srfi-1) :select (every)) + :export (build-validator-body + list-of pair-of + typecheck + current-procedure-name)) + +(define-syntax list-of + (syntax-rules () + ((_ variable (rule ...)) + (and (list? variable) + (every (lambda (x) (build-validator-body x (rule ...))) variable))) + ((_ variable rule) + (and (list? variable) + (every rule variable))))) + +(define-syntax-rule (pair-of variable a b) + (and (pair? variable) + (build-validator-body (car variable) a) + (build-validator-body (cdr variable) b))) + +;; DSL for specifying type predicates +;; Basically a procedure body, but the variable to test is implicit. +(define-syntax build-validator-body + (syntax-rules (and or list-of) + ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...)) + ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...)) + ((_ variable (proc args ...)) (proc variable args ...)) + ((_ variable proc) (proc variable)))) + +(define-syntax-rule (current-procedure-name) + ;; 1 since make-stack is at top of stack + (frame-procedure-name (stack-ref (make-stack #t) 1))) + +(define-syntax typecheck + (syntax-rules () + ((_ variable type-clause) + (let ((procedure-name (current-procedure-name))) + (typecheck variable type-clause procedure-name))) + ((_ variable type-clause procedure-name) + (unless (build-validator-body variable type-clause) + (scm-error 'wrong-type-arg procedure-name + "Invalid value for ~s. Expected ~s, got ~s" + (list (quote variable) (quote type-clause) variable) + #f))))) + diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm new file mode 100644 index 00000000..e5a334da --- /dev/null +++ b/module/sxml/namespaced.scm @@ -0,0 +1,266 @@ +(define-module (sxml namespaced) + :use-module (sxml ssax) + :use-module (sxml util) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util state-monad) + :use-module ((hnh util io) :select (->port)) + :export (xml->namespaced-sxml + namespaced-sxml->xml + namespaced-sxml->sxml + namespaced-sxml->sxml/namespaces + sxml->namespaced-sxml + xml + attribute + + make-xml-element + xml-element? + xml-element-tagname + xml-element-namespace + xml-element-attributes + + make-pi-element + pi-element? + pi-tag + pi-body + )) + +;; XML processing instruction elements (and other things with identical syntax) +;; For example: <?xml version="1.0" encoding="utf-8"?> would be encoded as +;; (make-pi-element 'xml "version=\"1.0\" encoding=\"utf-8\"") +;; tag should always be a symbol +;; body should always be a string +(define-record-type <pi-element> + (make-pi-element tag body) + pi-element? + (tag pi-tag) + (body pi-body)) + + +(define-record-type <xml-element> + (make-xml-element tagname namespace attributes) + xml-element? + (tagname xml-element-tagname) + (namespace xml-element-namespace) + (attributes xml-element-attributes)) + + +(define xml + (case-lambda + ((tag) (make-xml-element tag #f '())) + ((ns tag) (make-xml-element tag ns '())) + ((ns tag attrs) (make-xml-element tag ns attrs)))) + +(define (attribute xml attr) + (assoc-ref (xml-element-attributes xml) attr)) + + +(define* (parser key: trim-whitespace?) + (ssax:make-parser + + ;; DOCTYPE + ;; (lambda (port docname systemid internal-subset? seed) + ;; (format (current-error-port) + ;; "doctype: port=~s, docname=~s, systemid=~s, internal-subset?=~s, seed=~s~%" + ;; port docname systemid internal-subset? seed) + ;; (values #f '() '() seed)) + + ;; UNDECL-ROOT + ;; (lambda (elem-gi seed) + ;; (format (current-error-port) "Undecl-root: ~s~%" elem-gi) + ;; (values #f '() '() seed)) + + ;; DECL-ROOT + ;; (lambda (elem-gi seed) + ;; (format (current-error-port) "Decl-root: ~s~%" elem-gi) + ;; seed) + + NEW-LEVEL-SEED + (lambda (elem-gi attributes namespaces expected-content seed) + (cons + (list + (match elem-gi + ((ns . tag) (make-xml-element tag ns attributes)) + (tag (make-xml-element tag #f attributes)))) + seed)) + + FINISH-ELEMENT + (lambda (elem-gi attributes namespaces parent-seed seed) + (match seed + (((self . self-children) (parent . children) . rest) + `((,parent (,self ,@(reverse self-children)) ,@children) + ,@rest)))) + + CHAR-DATA-HANDLER + (lambda (str1 str2 seed) + (define s + (if trim-whitespace? + (string-trim-both (string-append str1 str2)) + (string-append str1 str2))) + (cond ((string-null? s) seed) + (else + (match seed + (((parent . children) . rest) + `((,parent ,(string-append str1 str2) + ,@children) + ,@rest)))))) + + PI + ((*DEFAULT* . (lambda (port pi-tag seed) + (let ((body (ssax:read-pi-body-as-string port))) + (match seed + (((parent . children) . rest) + `((,parent ,(make-pi-element pi-tag body) ,@children) + ,@rest))))))) + )) + + +(define* (xml->namespaced-sxml port-or-string key: (trim-whitespace? #t)) + (match (with-ssax-error-to-port + (current-error-port) + (lambda () ((parser trim-whitespace?: trim-whitespace?) + (->port port-or-string) + '((*TOP*))))) + ((('*TOP* . items)) + `(*TOP* ,@(reverse items))))) + +(define (pi-element->sxml pi) + `(*PI* ,(pi-tag pi) ,(pi-body pi))) + + + +(define (ns-pair->attribute pair) + (let ((fqdn short (car+cdr pair))) + (list (string->symbol (format #f "xmlns:~a" short)) + (symbol->string fqdn)))) + +;; Takes an association list from full namespace names (as symbols), to their +;; short forms, and returns a list containing xmlns:x-attributes suitable for +;; splicing into scheme's "regular" sxml. +(define (ns-alist->attributes ns) + (map ns-pair->attribute ns)) + + + +(define (get-prefix ns) + (do namespaces <- (get) + (cond ((assq-ref namespaces ns) => return) + (else (do prefix = (gensym "ns") + (put (acons ns prefix namespaces)) + (return prefix)))))) + + +(define (xml-element->sxml el) + (do tag <- (cond ((xml-element-namespace el) + => (lambda (ns) + (do pre <- (get-prefix ns) + (return + (string->symbol + (format #f "~a:~a" pre (xml-element-tagname el))))))) + (else (return (xml-element-tagname el)))) + (return + (lambda (children) + (cond ((null? (xml-element-attributes el)) + `(,tag ,@children)) + (else + `(,tag (@ ,@(map (lambda (p) + (call-with-values (lambda () (car+cdr p)) list)) + (xml-element-attributes el))) + ,@children))))))) + +(define (sxml->xml-element el namespaces) + (lambda (children) + (let ((tag-symb attrs + (match el + ((tag ('@ attrs ...)) + (values tag (map (lambda (p) (apply cons p)) attrs))) + ((tag) (values tag '()))))) + (let ((parts (string-split (symbol->string tag-symb) #\:))) + (cons (case (length parts) + ((1) (xml (assoc-ref namespaces #f) + (string->symbol (car parts)) attrs)) + ((2) + (cond ((assoc-ref namespaces (string->symbol (car parts))) + => (lambda (ns) (xml ns (string->symbol (cadr parts)) attrs))) + (else (scm-error 'missing-namespace "sxml->xml-element" + "Unknown namespace prefix encountered: ~s (on tag ~s)" + (list (car parts) (cadr parts)) + #f)))) + (else (scm-error 'misc-error "sxml->xml-element" + "Invalid QName: more than one colon ~s" + (list tag-symb) #f))) + children))))) + + +(define (namespaced-sxml->sxml* tree) + (cond ((null? tree) (return tree)) + ((string? tree) (return tree)) + ((pi-element? tree) (return (pi-element->sxml tree))) + ((not (pair? tree)) (return tree)) + ((car tree) symbol? + => (lambda (symb) + (case symb + ((*TOP*) (do children <- (sequence (map namespaced-sxml->sxml* + (cdr tree))) + + (return (cons '*TOP* children)))) + (else (return tree))))) + ((xml-element? (car tree)) + (do proc <- (xml-element->sxml (car tree)) + children <- (sequence (map namespaced-sxml->sxml* (cdr tree))) + (return (proc children)))) + + ;; list of xml-element? + (else (scm-error 'misc-error "namespaced-sxml->sxml*" + "Unexpected token in tree: ~s" + (list tree) + #f)))) + + +;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix. +;; Returns a sxml tree, with xmlns:<prefix>=namespace attributes +(define* (namespaced-sxml->sxml tree optional: (namespace-prefixes '())) + (let ((tree ns ((namespaced-sxml->sxml* tree) namespace-prefixes))) + ((get-root-element tree) + (lambda (root) + (add-attributes root (ns-alist->attributes ns)))))) + +(define* (namespaced-sxml->xml tree key: + (namespaces '()) + (port (current-output-port))) + ((@ (sxml simple) sxml->xml) + (namespaced-sxml->sxml tree namespaces) port)) + +;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix. +;; Returns two values: a sxml tree without declared namespaces +;; and a association list from namespace symbols, to used prefixes +(define* (namespaced-sxml->sxml/namespaces tree optional: (namespace-prefixes '())) + ((namespaced-sxml->sxml* tree) namespace-prefixes)) + +;; Takes an sxml tree, and an association list from prefixes to namespaces +;; Returns a namespaced sxml tree +(define (sxml->namespaced-sxml tree namespaces) + (match tree + (('*PI* tag body) (make-pi-element tag body)) + (('*TOP* rest ...) + `(*TOP* ,@(map (lambda (r) (sxml->namespaced-sxml r namespaces)) + rest))) + ((el ('@ attrs ...) rest ...) + ((sxml->xml-element `(,el (@ ,@attrs)) namespaces) + (map (lambda (el) (sxml->namespaced-sxml el namespaces)) + rest))) + ((el rest ...) + ((sxml->xml-element `(,el) namespaces) + (map (lambda (el) (sxml->namespaced-sxml el namespaces)) + rest))) + (atom atom))) + +;;; TODO read intro-comment in SSAX file +;;; TODO Figure out how to still use (sxml match) and (sxml xpath) with these +;;; new trees (probably rewriting to a "regular" sxml tree, and keeping +;;; a strict mapping of namespaces) + diff --git a/module/sxml/namespaced/util.scm b/module/sxml/namespaced/util.scm new file mode 100644 index 00000000..6f93e362 --- /dev/null +++ b/module/sxml/namespaced/util.scm @@ -0,0 +1,45 @@ +(define-module (sxml namespaced util) + :use-module (sxml namespaced) + :use-module (srfi srfi-1) + :use-module ((ice-9 control) :select (call/ec)) + :export (xml-element-hash-key + find-element + element-matches? + on-root-element + root-element + )) + +(define (xml-element-hash-key tag) + "Returns a value suitable as a key to hash-ref (and family)" + (cons (xml-element-namespace tag) + (xml-element-tagname tag))) + +(define (find-element target list) + (define target* (xml-element-hash-key target)) + (find (lambda (x) (and (list? x) + (not (null? x)) + (xml-element? (car x)) + (equal? target* (xml-element-hash-key (car x))))) + list)) + + +(define (element-matches? target-el tree) + (and (not (null? tree)) + (equal? + (xml-element-hash-key target-el) + (xml-element-hash-key (car tree))))) + + +(define (on-root-element proc tree) + (cond ((and (eq? '*TOP* (car tree)) + (pi-element? (cadr tree))) + (cons* (car tree) (cadr tree) + (proc (caddr tree)))) + ((eq? '*TOP* (car tree)) + (cons (car tree) + (proc (cadr tree)))) + (else (proc (car tree))))) + +(define (root-element tree) + (call/ec (lambda (return) + (on-root-element return tree)))) diff --git a/module/sxml/util.scm b/module/sxml/util.scm new file mode 100644 index 00000000..532141b2 --- /dev/null +++ b/module/sxml/util.scm @@ -0,0 +1,22 @@ +(define-module (sxml util) + :use-module (ice-9 match) + :export (get-root-element add-attributes)) + +(define (get-root-element tree) + (match tree + (('*TOP* ('*PI* 'xml body) (root . children)) + (lambda (modifier) `(*TOP* (*PI* xml ,body) + ,(modifier `(,root ,@children))))) + (('*TOP* (root . children)) + (lambda (modifier) `(*TOP* ,(modifier `(,root ,@children))))) + ((root . children) + (lambda (modifier) `(*TOP* ,(modifier `(,root ,@children))))))) + +(define (add-attributes element added-attributes) + (match element + ((el ('@ . attributes) . children) + `(,el (@ ,@attributes ,@added-attributes) + ,@children)) + ((el . children) + `(,el (@ ,@added-attributes) + ,@children)))) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 0f000ba5..7930bf92 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -2,12 +2,21 @@ :use-module (hnh util) :use-module (vcomponent base) :use-module (vcomponent config) - ;; :use-module ((vcomponent util instance methods) - ;; :select (make-vcomponent)) :use-module ((vcomponent util parse-cal-path) :select (parse-cal-path)) - :re-export (make-vcomponent + :re-export ( + vcomponent + set-properties + properties + children + type + prop + prop* parse-cal-path + param + ;; value + vline? + vline-parameters ;; configuration items calendar-files default-calendar)) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index df452f62..ff2382bf 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,38 +1,39 @@ (define-module (vcomponent base) :use-module (hnh util) :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-9 gnu) :use-module (srfi srfi-17) :use-module (srfi srfi-88) - :use-module (ice-9 hash-table) - :export (make-vline + :use-module (hnh util object) + :use-module (hnh util lens) + :use-module (hnh util table) + :use-module (hnh util uuid) + :export (vline vline? - vline-key + vline-value + key + vline-parameters vline-source - make-vcomponent + vcomponent vcomponent? children type parent + add-child - add-child! remove-child! - - delete-property! + remove-property prop* prop extract extract* - delete-parameter! - value + set-properties + + remove-parameter + ;; value param parameters properties - copy-vcomponent x-property? internal-field? - - ) ) @@ -50,163 +51,95 @@ ;;; </vcomponent> ;;; -(define-record-type <vline> - (make-vline% key value parameters) - vline? - (key vline-key) - (value get-vline-value set-vline-value!) - (parameters get-vline-parameters) - (source get-source set-source!) - ) - -(set-record-type-printer! - <vline> - (lambda (v p) - (format p "#<<vline> key: ~s value: ~s parameters: ~s>" - (vline-key v) - (get-vline-value v) - (hash-map->list list (get-vline-parameters v))))) - -(define vline-source - (make-procedure-with-setter - get-source set-source!)) - -(define* (make-vline key value optional: (ht (make-hash-table))) - (make-vline% key value ht)) - -(define-record-type <vcomponent> - (make-vcomponent% type children parent properties) - vcomponent? - (type type) - (children children set-component-children!) - (parent get-component-parent set-component-parent!) - (properties get-component-properties)) - -((@ (srfi srfi-9 gnu) set-record-type-printer!) - <vcomponent> - (lambda (c p) - (format p "#<<vcomponent> ~a, len(child)=~a, parent=~a>" - (type c) - (length (children c)) - (and=> (get-component-parent c) type)))) - -;; TODO should this also update the parent -(define parent - (make-procedure-with-setter - get-component-parent set-component-parent!)) - -(define* (make-vcomponent optional: (type 'VIRTUAL)) - (make-vcomponent% type '() #f (make-hash-table))) - -(define (add-child! parent child) - (set-component-children! parent (cons child (children parent))) - (set-component-parent! child parent)) - -(define (remove-child! parent-component child) - (unless (eq? parent-component (parent child)) - (scm-error - 'wrong-type-arg "remove-child!" "Child doesn't belong to parent" - (list parent-component child) #f)) - (set-component-children! parent-component (delq1! child (children parent-component))) - (set-component-parent! child #f)) - -;;; TODO key=DTSTART, (date? value) => #t -;;; KRÄVER att (props vline 'VALUE) <- "DATE" -(define (set-property! component key value) - (let ((ht (get-component-properties component))) - (cond [(hashq-ref ht key #f) - => (lambda (vline) (set-vline-value! vline value))] - [else (hashq-set! ht key (make-vline key value))]))) +(define (print-vline v p) + (format p "#<<vline> key: ~s value: ~s parameters: ~s>" + (key v) + (vline-value v) + #f + ;; (hash-map->list list (get-vline-parameters v)) + )) +(define-type (vline printer: print-vline) + (key type: symbol?) + (vline-value) + (vline-parameters default: (table) type: table?) + (vline-source default: "" type: string?)) - +(define (print-vcomponent c p) + (format p "#<<vcomponent> ~a>" + (type c))) -;; vline → value -(define value - (make-procedure-with-setter - get-vline-value set-vline-value!)) -;; vcomponent x (or str symb) → vline -(define (get-prop* component prop) - (hashq-ref (get-component-properties component) - (as-symb prop))) +(define false? not) -(define (set-prop*! component key value) - (hashq-set! (get-component-properties component) - (as-symb key) value)) +(define-type (vcomponent printer: print-vcomponent) + (type type: symbol?) + (vcomponent-children + default: (table) type: table?) + (component-properties + default: (table) type: table?) + (parent default: #f type: (or false? vcomponent?))) (define prop* - (make-procedure-with-setter - get-prop* - set-prop*!)) - -(define (delete-property! component key) - (hashq-remove! (get-component-properties component) - (as-symb key))) + (case-lambda + ((object key) + (table-get (component-properties object) key)) + ((object key value) + (component-properties object + (table-put (component-properties object) key value))))) + +(define (children c) + (map cdr (table->list (vcomponent-children c)))) + +(define (add-child parent* child) + (modify parent* vcomponent-children + (lambda (table) + (let ((child + (if (prop child 'UID) + child + (prop child 'UID (uuid))))) + (table-put table + (as-symb (prop child 'UID)) + (parent child parent*)))))) + -;; vcomponent x (or str symb) → value -(define (get-prop component key) - (let ((props (get-prop* component key))) - (cond [(not props) #f] - [(list? props) (map value props)] - [else (value props)]))) - -;; TODO do something sensible here -(define (set-prop! component key value) - (set-property! component (as-symb key) value)) - +;; (define prop (compose-lens vline-value prop*)) (define prop - (make-procedure-with-setter - get-prop - set-prop!)) - + (case-lambda + ((comp key) (and=> (prop* comp key) vline-value)) + ((comp k v) + (cond ((prop* comp k) + => (lambda (vline) + (prop* comp k (vline-value vline v)))) + (else + (prop* comp k (vline key: k vline-value: v))))))) + +(define (remove-property component key) + (component-properties component + (table-remove (component-properties component) key))) (define param - (make-procedure-with-setter - (lambda (vline parameter-key) - ;; TODO `list' is a hack since a bit to much code depends - ;; on prop always returning a list of values. - (and=> (hashq-ref (get-vline-parameters vline) - (as-symb parameter-key)) - list)) - (lambda (vline parameter-key val) - (hashq-set! (get-vline-parameters vline) - (as-symb parameter-key) val)))) + ;; TODO list? + (case-lambda ((vline key) (and=> (table-get (vline-parameters vline) key) list)) + ((vline k v) (vline-parameters + vline + (table-put (vline-parameters vline) k v))))) - -(define (delete-parameter! vline parameter-key) - (hashq-remove! (get-vline-parameters vline) - (as-symb parameter-key))) +(define (remove-parameter vline key) + (vline-parameters vline + (table-remove (vline-parameters vline) key))) ;; Returns the parameters of a property as an assoc list. ;; @code{(map car <>)} leads to available parameters. (define (parameters vline) - (hash-map->list list (get-vline-parameters vline))) + (map (compose list car+cdr) + (table->list (vline-parameters vline)))) (define (properties component) - (hash-map->list cons (get-component-properties component))) - -(define (copy-vline vline) - (make-vline (vline-key vline) - (get-vline-value vline) - ;; TODO deep-copy on parameters? - (get-vline-parameters vline))) - -(define (copy-vcomponent component) - (make-vcomponent% - (type component) - ;; TODO deep copy? - (children component) - (parent component) - ;; properties - (alist->hashq-table - (hash-map->list (lambda (key value) - (cons key (if (list? value) - (map copy-vline value) - (copy-vline value)))) - (get-component-properties component))))) + (map (compose list car+cdr) + (table->list (component-properties component)))) (define (extract field) (lambda (e) (prop e field))) @@ -221,3 +154,10 @@ (string=? prefix (string-take-to (symbol->string symbol) (string-length prefix)))) + + +(define (set-properties component . pairs) + ;; (format (current-error-port) "component: ~s, pairs: ~s~%" component pairs) + (fold (lambda (pair component) (prop component (car pair) (cdr pair))) + component + pairs)) diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm new file mode 100644 index 00000000..5704b0f1 --- /dev/null +++ b/module/vcomponent/create.scm @@ -0,0 +1,104 @@ +(define-module (vcomponent create) + :use-module ((vcomponent base) :prefix vcs-) + :use-module ((vcomponent base) + :select (vline key add-child prop* vline?)) + :use-module ((srfi srfi-1) :select (fold last drop-right car+cdr)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-17) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((hnh util table) :select (alist->table)) + :use-module ((hnh util) :select (swap init+last kvlist->assq ->)) + :export (with-parameters + as-list + vcomponent + vcalendar vevent + vtimezone standard daylight + )) + +;; TODO allow parameters and list values at same time + + + +;; Convert a scheme keyword to a symbol suitable for us +(define (keyword->key keyword) + (-> keyword + keyword->string + string-upcase + string->symbol)) + +(define (symbol-upcase symbol) + (-> symbol + symbol->string + string-upcase + string->symbol)) + +;; Upcase the keys in an association list. Keys must be symbols. +(define (upcase-keys alist) + (map (lambda (pair) (cons (symbol-upcase (car pair)) + (cdr pair))) + alist)) + + + +(define (with-parameters . args) + (define-values (parameters value) + (init+last args)) + (vline + key: 'PLACEHOLDER + vline-value: value + vline-parameters: + (-> parameters + kvlist->assq + upcase-keys + alist->table))) + + + +(define-immutable-record-type <list-value> + (make-list-value value) + list-value? + (value list-value-value)) + +(define (as-list arg) + (make-list-value arg)) + + + +(define (vcomponent type . attrs*) + (define-values (attrs children) + (cond ((null? attrs*) (values '() '())) + ((even? (length attrs*)) (values attrs* '())) + (else (init+last attrs*)))) + ;; TODO add-child requires a UID on the child + ;; Possibly just genenerate one here if missing + (fold (swap add-child) + (fold (lambda (pair component) + (let ((k value (car+cdr pair))) + (prop* component k + (cond ((vline? value) + (key value k)) + ((list-value? value) + (map (lambda (value) (vline key: k vline-value: value)) + (list-value-value value))) + (else (vline key: k vline-value: value)))))) + (vcs-vcomponent + type: type) + (upcase-keys (kvlist->assq attrs))) + children)) + +(define (vcalendar . attrs) + (apply vcomponent 'VCALENDAR attrs)) + +(define (vevent . attrs) + (apply vcomponent 'VEVENT attrs)) + +(define (vtimezone . attrs) + (apply vcomponent 'VTIMEZONE attrs)) + +(define (standard . attrs) + (apply vcomponent 'STANDARD attrs)) + +(define (daylight . attrs) + (apply vcomponent 'DAYLIGHT attrs)) diff --git a/module/vcomponent/data-stores/caldav.scm b/module/vcomponent/data-stores/caldav.scm new file mode 100644 index 00000000..f9ba61c1 --- /dev/null +++ b/module/vcomponent/data-stores/caldav.scm @@ -0,0 +1,270 @@ +(define-module (vcomponent data-stores caldav) + ) + +(use-modules (srfi srfi-71) + (srfi srfi-88) + (rnrs bytevectors) + (rnrs io ports) + ((ice-9 binary-ports) :select (call-with-output-bytevector)) + (web request) + (web response) + (web client) + (web uri) + ;; (web http) ; + (sxml simple) + (oop goops) + (vcomponent data-stores common) + ((hnh util) :select (->)) + (web http dav) + ) + + + +(define-class <caldav-data-store> (<calendar-data-store>) + (host init-keyword: host: + getter: host) + (user init-keyword: user: + getter: user) + (calendar-path init-keyword: calendar-path: + accessor: calendar-path) + (password init-keyword: password: + getter: store-password)) + + +(define local-uri + (case-lambda ((this path) + (build-uri 'https + host: (host this) + path: path)) + ((this) + (build-uri 'https + host: (host this) + path: (calendar-path this))))) + + +(define* (make-caldav-store key: host user path password) + (define store + (make <caldav-data-store> + host: host + user: user + password: (string->symbol password) + calendar-path: path)) + + + (let* ((principal-path + (get-principal (local-uri store "/") + password: (store-password store))) + (calendar-home-set + (get-calendar-home-set (local-uri store principal-path) + password: (store-password store))) + (calendar-paths + (get-calendar-paths (local-uri store calendar-home-set) + password: (store-password store)))) + (set! (calendar-path store) + (car calendar-paths))) + + store) + +(define-method (write (this <caldav-data-store>) port) + (write `(make-caldav-store host: ,(host this) + user: ,(user this) + calendar-path: ,(calendar-path this) + password: ,(store-password this)) + port)) + +(define store + (make-caldav-store host: "dav.fruux.com" + user: "a3298201184" + password: "YjMyOTc0NjUwMDk6YXRhc3llanY2MGtu")) + +#; +(define-method (calendar-base (this <caldav-data-store>)) + (build-uri 'https + host: (host this) + path: (calendar-path this))) + + +;; (define-method (get-all (this <caldav-data-store>)) +;; ) + +(define-method (get-by-uid (this <caldav-data-store>) + (uid <string>)) + (let ((uids + (dav (local-uri this) + method: 'REPORT + authorization: `(Basic ,(store-password this)) + depth: 1 + body: + `(c:calendar-query + (@ (xmlns:c ,caldav)) + (d:prop (@ (xmlns:d "DAV:")) + (d:getetag) + #; (c:calendar-data) + ) + (c:filter + (c:comp-filter + (@ (name "VCALENDAR")) + (c:comp-filter + (@ (name "VEVENT")) + (c:prop-filter + (@ (name "UID")) + (c:text-match (@ (collation "i;octet")) + ,uid))))))))) + uids)) + + +(define-method (search (this <caldav-data-store>) + (filter <pair>)) + (let ((uids + (dav (local-uri this) + method: 'REPORT + authorization: `(Basic ,(store-password this)) + depth: 1 + body: + `(c:calendar-query + (@ (xmlns:c ,caldav)) + (d:prop (@ (xmlns:d "DAV:")) + (d:getetag) + (c:calendar-data + (c:comp (@ (name "VCALENDAR")) + (c:prop (@ (name "PRODID"))))) + #; (c:calendar-data) + ) + ,filter)))) + uids)) + +(define-method (search (this <caldav-data-store>) + (filter <string>) + (field <string>)) + (search store + `(c:filter + (c:comp-filter + (@ (name "VCALENDAR")) + (c:comp-filter + (@ (name "VEVENT")) + (c:prop-filter + (@ (name ,field)) + (c:text-match (@ (collation "i;octet")) + ,filter))))))) + + + +(define-method (list-calendars (this <caldav-data-store>)) + ) + + + + +(get-principal) ; => "/principals/uid/a3298201184/" + +(get-calendar-home-set "/principals/uid/a3298201184/") +;; => "/calendars/a3298201184/" + +(get-calendar-paths "/calendars/a3298201184/") +;; => ("/calendars/a3298201184/b85ba2e9-18aa-4451-91bb-b52da930e977/") + + + +(define user "a3298201184") +(define calendar "b85ba2e9-18aa-4451-91bb-b52da930e977") +(define password (string->symbol "YjMyOTc0NjUwMDk6YXRhc3llanY2MGtu")) +(define auth `(Basic ,password)) + + + + + + +(define uri + (build-uri 'https + host: "dav.fruux.com" + path: "/calendars/a3298201184/b85ba2e9-18aa-4451-91bb-b52da930e977/ff95c36c-6ae9-4aa0-b08f-c52d84bf4f26.ics")) + +(define-values (response body) + (dav uri + method: 'GET + authorization: auth)) + + + + +(define-values (response body) + (dav uri + method: 'PROPFIND + authorization: auth + body: + `(C:supported-collation-set (@ (xmlns:C ,caldav))))) + +(define-values (response body) + (dav uri + method: 'REPORT + authorization: auth + body: + `(C:calendar-query + (@ (xmlns:C ,caldav)) + (D:prop (@ (xmlns:D "DAV:")) + (D:getetac) + (C:calendar-data)) + (C:filter + (C:comp-filter (@ (name "VCALENDAR")) + (C:comp-filter (@ (name "VEVENT")) + (C:prop-filter (@ (name "UID")) + (C:text-match (@ (collation "i;utf-8")) + "Admittansen")))))))) + + + + + + +(define (add) + ;; add new event + (http-request 'PUT + path: "/path-on-server/<filename>.ics" + headers: + ((if-none-match "*") + (content-type "text/calendar")) + body: (ics:serialize event-with-wrapping-calendar) + )) + + +(define (get-by-time-range) + (http-request 'REPORT + path: "/calendar/<calendar-name>" + body: + ;; See RFC 4791 7.8.1 + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (C:calendar-query + (@ (xmlns:D "DAV:") + (xmlns:C "urn:ietf:params:xml:ns:caldav")) + (D:prop + (D:getetag) + (C:calendar-data + (C:comp + (@ (name "VCALENDAR")) + (C:prop (@ (name "VERSION"))) + (C:prop (@ name "VEVENT") + (C:prop (@ (name "SUMMARY"))) + ...)))) + (C:filter + (C:comp-filter + (@ (name "VCALENDAR")) + (C:comp-filter + (@ (name "VEVENT")) + (C:time-range + (@ (start ,(datetime->string + start + "~Y~m~dT~H~M~S~Z")) + (end ,(datetime->string + end + "~Y~m~dT~H~M~S~Z"))))))))))) + + + + + +;; (use-modules (curl)) +;; (define c (curl-easy-init)) +;; (curl-easy-setopt c 'url "https://hornquist.se") + +;; (curl-easy-perform handle) diff --git a/module/vcomponent/data-stores/common.scm b/module/vcomponent/data-stores/common.scm new file mode 100644 index 00000000..2fb4422a --- /dev/null +++ b/module/vcomponent/data-stores/common.scm @@ -0,0 +1,43 @@ +(define-module (vcomponent data-stores common) + :use-module ((srfi srfi-88) :select ()) + :use-module (oop goops) + :export (<calendar-data-store> + ;; path + get-all + get-by-uid)) + + +(define-class <calendar-data-store> () + ;; (path init-keyword: path: + ;; getter: path) + ) + + +;;; In (calp server routes) + + + + +;;; Load - Load store into memero +;;; Dump - Save store into "disk" + + +(define-method (get-all (this <calendar-data-store>)) + (scm-error 'not-implemented "get-all" + "Get-all is not implemented for ~s" + (class-of this) + #f)) + +(define-method (get-by-uid (this <calendar-data-store>) (uid <string>)) + (scm-error 'not-implemented "get-by-uid" + "Get-by-uid is not implemented for ~s" + (class-of this) + #f)) + + +(define-method (color (this <calendar-data-store>)) + "") + + +(define-method (displayname (this <calendar-data-store>)) + "") diff --git a/module/vcomponent/data-stores/file.scm b/module/vcomponent/data-stores/file.scm new file mode 100644 index 00000000..54676224 --- /dev/null +++ b/module/vcomponent/data-stores/file.scm @@ -0,0 +1,32 @@ +(define-module (vcomponent data-stores file) + :use-module (oop goops) + :use-module ((srfi srfi-88) :select ()) + :use-module ((calp) :select (prodid)) + :use-module (vcomponent data-stores common) + :use-module ((vcomponent formats ical) :select (serialize deserialize)) + ) + +(define-class <file-data-store> (<calendar-data-store>) + (path getter: path + init-keyword: path:)) + +(define (make-file-store path) + (make <file-store> path: path)) + +(define-method (get-all (this <file-data-store>)) + ;; X-WR-CALNAME ⇒ NAME + ;; X-WR-CALDESC + (call-with-input-file (path this) + deserialize)) + +(define-method (get-by-uid (this <file-data-store>) (uid <string>)) + #f + ) + +(define-method (queue-write (this <file-data-store>) vcomponent) + ) + +(define-method (flush (this <file-data-store>)) + (with-atomic-output-to-file (path this) + (lambda () (serialize (data this) (current-output-port)))) + ) diff --git a/module/vcomponent/data-stores/meta.scm b/module/vcomponent/data-stores/meta.scm new file mode 100644 index 00000000..8ec5f7fd --- /dev/null +++ b/module/vcomponent/data-stores/meta.scm @@ -0,0 +1,29 @@ +;;; Commentary: +;;; A virtual data store which uses other data stores for its storage. +;;; Used to merge stores into larger stores +;;; Code: + +(define-module (vcomponent data-stores meta) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-41) + :use-module ((srfi srfi-88) :select ()) + :export () + ) + +(define-class <meta-data-store> (<calendar-data-store>) + (stores accessor: stores + init-value: '() + init-keyword: stores:)) + + + +(define-method (get-all (this <meta-data-store>)) + (map get-all (stores this))) + +(define-method (get-by-uid (this <meta-data-store>) (uid <string>)) + (stream-car + (stream-append + (steam-map (lambda (store) (get-by-uid store uid)) + (list->stream (stores this))) + (stream #f)))) diff --git a/module/vcomponent/data-stores/sqlite.scm b/module/vcomponent/data-stores/sqlite.scm new file mode 100644 index 00000000..5d487028 --- /dev/null +++ b/module/vcomponent/data-stores/sqlite.scm @@ -0,0 +1,186 @@ +(define-module (vcomponent data-stores sqlite) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) + :use-module ((srfi srfi-88) :select ()) + :use-module (vcomponent) + :use-module ((vcomponent formats ical) :prefix #{ical:}#) + :use-module ((hnh util) :select (aif)) + ) + + +(catch 'misc-error + (lambda () + (use-modules (sqlite3)) + (provide 'data-store-sqlite)) + (lambda args 'no-op)) + +;; (define (sqlite-exec db str) +;; (display str) +;; ((@ (sqlite3) sqlite-exec) db str)) + +(define-class <sqlite-data-store> (<calendar-data-store>) + (database accessor: database) + (name init-keyword: name: getter: calendar-name) + ) + +(define (initialize-database db) + ;;; Setup Content type + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS content_type +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (let ((stmt (sqlite-prepare db " +INSERT OR IGNORE INTO content_type +( name ) VALUES ( ? )"))) + (for-each (lambda (content-type) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt ) + (sqlite-step stmt)) + '("ical" + "xcal" + "jcal"))) + + ;;; Setup calendar + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar_properties +( id INTEGER PRIMARY KEY AUTOINCREMENT +, calendar INTEGER NOT NULL +, key TEXT NOT NULL +, value TEXT NOT NULL +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + ;; INSERT INTO calendar_properties (id, key, value) + ;; VALUES ( (SELECT id FROM calendar WHERE name = 'Calendar') + ;; , 'color' + ;; , '#1E90FF') + + ;;; Setup event + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event +( uid TEXT PRIMARY KEY +, content_type INTEGER NOT NULL +, content TEXT NOT NULL +, calendar INTEGER NOT NULL +, FOREIGN KEY (content_type) REFERENCES content_type(id) +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances +( id INTEGER PRIMARY KEY AUTOINCREMENT +, event TEXT NOT NULL +, start DATETIME NOT NULL +, end DATETIME +, FOREIGN KEY (event) REFERENCES event(uid) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances_valid_range +( start DATETIME NOT NULL +, end DATETIME NOT NULL +)") + ) + +(define-method (initialize (this <sqlite-data-store>) args) + (next-method) + (if (calendar-name this) + (set! (database this) (sqlite-open (path this))) + (let ((path db-name + (aif (string-rindex (path this) #\#) + (values (substring (path this) 0 it) + (substring (path this) (1+ it))) + (scm-error 'misc-error "(initialize <sqlite-data-store>)" + "Target calendar name not specified" + '() #f)))) + (set! (database this) (sqlite-open path)) + (slot-set! this 'name db-name))) + + (initialize-database (database this))) + + +(define-method (get-calendar (this <sqlite-data-store>)) + (let ((db (database this)) + (calendar (vcomponent type: 'VCALENDAR))) + (let ((stmt (sqlite-prepare db " +SELECT key, value FROM calendar_properties cp +LEFT JOIN calendar c ON cp.calendar = c.id +WHERE c.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (let ((key (vector-ref row 0)) + (value (vector-ref row 1))) + (set-property! calendar + (string->symbol key) + value)) + calendar) + calendar + stmt)) + + (let ((stmt (sqlite-prepare db " +SELECT content_type.name, content +FROM event +LEFT JOIN calendar ON event.calendar = calendar.id +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE calendar.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (case (string->symbol (vector-ref row 0)) + ((ical) + (add-child! calendar + (call-with-input-string (vector-ref row 1) + ics:deserialize)) + calendar) + (else + (scm-error 'misc-error "(get-calendar <sqlite-data-store>)" + "Only iCal data supported, got ~a" + (list (vector-ref row 0)) #f) + )) + ) + calendar + stmt)) + + calendar)) + + +#; +(define-method (get-by-uid (this <sqlite-data-store>) (uid <string>)) + (let ((stmt (sqlite-prepare db " +SELECT name, content +FROM event +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE event.uid = ?"))) + (sqlite-bind-arguments stmt uid) + (cond ((sqlite-step stmt) + => (lambda (record) + (case (string->symbol (vector-ref content 0)) + ((ics) + ;; TODO dispatch to higher instance + ) + (else + (scm-error 'value-error "get-by-uid" + "Can only deserialize ics (uid=~s)" + (list uid) #f))) + + )) + (else + ;; TODO possibly throw no-such-value + #f + )) + + ) + ) diff --git a/module/vcomponent/data-stores/vdir.scm b/module/vcomponent/data-stores/vdir.scm new file mode 100644 index 00000000..9320c44e --- /dev/null +++ b/module/vcomponent/data-stores/vdir.scm @@ -0,0 +1,89 @@ +(define-module (vcomponent data-stores vdir) + :use-module (hnh util) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) + :use-module ((srfi srfi-88) :select ()) + :use-module (hnh util path) + :use-module ((vcomponent formats ical) :select (serialize deserialize)) + :use-module ((ice-9 ftw) :select (scandir)) + :use-module (ice-9 rdelim) + :use-module (srfi srfi-1) + :use-module (vcomponent base) + :export ()) + +(define-class <vdir-data-store> (<calendar-data-store>) + (path getter: path + init-keyword: path:) + (loaded-calendar accessor: loaded-calendar + init-value: #f) + (uid-map accessor: uid-map + init-value: #f) + ) + +(define (make-vdir-store path) + (make <vdir-data-store> path: path)) + +(define* (get-attribute path key key: dflt) + (catch 'system-error + (lambda () (call-with-input-file (path-append path key) read-line)) + (const dflt))) + + +(define-method (get-all (this <vdir-data-store>)) + (let ((files (scandir (path this) (lambda (item) (string-ci=? "ics" (filename-extension item))))) + (calendar + (fold (swap add-child) + (set-properties (vcomponent type: 'VCALENDAR) + (cons 'NAME (get-attribute (path this) "displayname")) + (cons 'COLOR (get-attribute (path this) "color" "#FFFFFF"))) + (append-map (lambda (file) + (define cal + (call-with-input-file (path-append (path this) file) + deserialize)) + (unless (eq? 'VCALENDAR (type cal)) + (scm-error 'misc-error "get-all<vdir-data-store>" + "Unexpected top level component. Expected VCALENDAR, got ~a. In file ~s" + (list (type cal) file))) + (each cal children + (lambda (child) + (prop child '-X-HNH-FILENAME file)))) + files)))) + (set! (loaded-calendar this) calendar) + calendar)) + + +(define-method (get-by-uid (this <vdir-data-store>) (uid <string>)) + (unless (uid-map this) + (let ((cal + (or (loaded-calendar this) + (get-all this)))) + (define ht (make-hash-table)) + (for-each (lambda (ev) (hash-set! ht (uid ev) ev)) + (children cal)) + (set! (uid-map this) ht))) + (hash-ref m uid #f)) + + +(define (wrap-for-output . vcomponents) + (fold (swap add-child) + (set-properties (vcomponent type: 'VCALENDAR) + (cons 'VERSION "2.0") + (cons 'PRODID (prodid)) + (cons 'CALSCALE "GREGORIAN")) + vcomponents)) + +(define-method (queue-write (this <vdir-data-store>) vcomponent) + ;; TODO Multiple components + (let ((filename + (cond ((prop vcomponent '-X-HNH-FILENAME) + => identity) + (else + (format #f "~a.ics" (prop vcomponent 'UID)))))) + (with-atomic-output-to-file (path-append (path this) filename) + (lambda () (serialize (wrap-for-output vcomponent) (current-output-port)))))) + +(define-method (flush (this <vdir-data-store>)) + (sync)) + +;; (define (get-in-date-interval )) diff --git a/module/vcomponent/data-stores/virtual.scm b/module/vcomponent/data-stores/virtual.scm new file mode 100644 index 00000000..03c115f5 --- /dev/null +++ b/module/vcomponent/data-stores/virtual.scm @@ -0,0 +1,22 @@ +(define-module (vcomponent data-stores virtual) + :use-module (oop goops) + :use-module ((srfi srfi-88) :select ()) + :use-module (vcomponent data-stores common) + :export (make-file-store)) + +(define-class <virtual-data-store> (<calendar-data-store>) + ) + +(define-method (get-all (this <virtual-data-store>)) + #f) + +(define-method (get-by-uid (this <virtual-data-store>) + (uid <string>)) + #f) + + +(define-method (color (this <virtual-data-store>)) + "") + +(define-method (displayname (this <virtual-data-store>)) + "Virtual Calendar") diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 440ec5fd..5aa6f4ab 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -227,75 +227,89 @@ Event must have the DTSTART and DTEND protperty set." ;; event is for limiter (define (zoneinfo->vtimezone zoneinfo zone-name event) - (define vtimezone (make-vcomponent 'VTIMEZONE)) (define last-until (datetime date: (date month: 1 day: 1))) (define last-offset (timespec-zero)) - (set! (prop vtimezone 'TZID) zone-name) - - (for zone-entry in (filter (relevant-zone-entry? event) (get-zone zoneinfo zone-name)) - (cond [(zone-entry-rule zone-entry) timespec? - => (lambda (inline-rule) - (let ((component (make-vcomponent 'DAYLIGHT)) - (new-timespec (timespec-add - (zone-entry-stdoff zone-entry) - inline-rule))) - (set! (prop component 'DTSTART) last-until - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) new-timespec - (prop component 'TZNAME) (zone-entry-format zone-entry) - last-until (zone-entry-until zone-entry) - last-offset new-timespec) - (add-child! vtimezone component)))] - - [(zone-entry-rule zone-entry) - => (lambda (rule-name) - (map (lambda (rule) - (let ((component (make-vcomponent - ;; NOTE the zoneinfo database doesn't - ;; come with information if a given - ;; rule is in standard or daylight time, - ;; since that's mostly nonsencical - ;; (e.g. war- and peacetime). - ;; But the ical standard requires that, - ;; so this is a fair compromize. - (if (string-null? (rule-letters rule)) - 'STANDARD 'DAYLIGHT))) - (new-timespec (timespec-add - (zone-entry-stdoff zone-entry) - (rule-save rule)))) - - (set! (prop component 'DTSTART) (rule->dtstart rule) - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) new-timespec - (prop component 'TZNAME) (zone-format - (zone-entry-format zone-entry) - (rule-letters rule)) - ;; NOTE this can both be a number or the - ;; symbol 'maximum - last-until (zone-entry-until zone-entry) - last-offset new-timespec) - - (awhen (rule->rrule rule) - (set! (prop component 'RRULE) it)) - - (add-child! vtimezone component))) - ;; some of the rules might not apply to us since we only - ;; started using that rule set later. It's also possible - ;; that we stopped using a ruleset which continues existing. - ;; - ;; Both these are filtered here. - (filter - (relevant-zone-rule? event) - (get-rule zoneinfo rule-name))))] - - [else ; no rule - (let ((component (make-vcomponent 'STANDARD))) - ;; DTSTART MUST be a datetime in local time - (set! (prop component 'DTSTART) last-until - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) (zone-entry-stdoff zone-entry) - (prop component 'TZNAME) (zone-entry-format zone-entry) - last-until (zone-entry-until zone-entry) - last-offset (zone-entry-stdoff zone-entry)) - (add-child! vtimezone component))])) - vtimezone) + + (fold (lambda (zone-entry vtimezone) + (cond [(zone-entry-rule zone-entry) timespec? + => (lambda (inline-rule) + (let ((component (vcomponent type: 'DAYLIGHT)) + (new-timespec (timespec-add + (zone-entry-stdoff zone-entry) + inline-rule))) + (let ((component + (set-properties + component + (cons 'DTSTART last-until) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO new-timespec) + (cons 'TZNAME (zone-entry-format zone-entry))))) + (set! last-until (zone-entry-until zone-entry) + last-offset new-timespec) + (add-child vtimezone component))))] + + [(zone-entry-rule zone-entry) + => (lambda (rule-name) + (fold (lambda (rule vtimezone) + (let ((component (vcomponent + type: + ;; NOTE the zoneinfo database doesn't + ;; come with information if a given + ;; rule is in standard or daylight time, + ;; since that's mostly nonsencical + ;; (e.g. war- and peacetime). + ;; But the ical standard requires that, + ;; so this is a fair compromize. + (if (string-null? (rule-letters rule)) + 'STANDARD 'DAYLIGHT))) + (new-timespec (timespec-add + (zone-entry-stdoff zone-entry) + (rule-save rule)))) + + (let ((component + (set-properties + component + (cons 'DTSTART (rule->dtstart rule)) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO new-timespec) + (cons 'TZNAME (zone-format + (zone-entry-format zone-entry) + (rule-letters rule)))))) + + (set! ;; NOTE this can both be a number or the + ;; symbol 'maximum + last-until (zone-entry-until zone-entry) + last-offset new-timespec) + + (add-child + vtimezone + (cond ((rule->rrule rule) + => (lambda (it) (prop component 'RRULE it))) + (else component)))))) + vtimezone + ;; some of the rules might not apply to us since we only + ;; started using that rule set later. It's also possible + ;; that we stopped using a ruleset which continues existing. + ;; + ;; Both these are filtered here. + (filter + (relevant-zone-rule? event) + (get-rule zoneinfo rule-name))))] + + [else ; no rule + ;; DTSTART MUST be a datetime in local time + (let ((component + (set-properties + (vcomponent type: 'STANDARD) + (cons 'DTSTART last-until) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO (zone-entry-stdoff zone-entry)) + (cons 'TZNAME (zone-entry-format zone-entry))))) + (set! last-until (zone-entry-until zone-entry) + last-offset (zone-entry-stdoff zone-entry)) + (add-child vtimezone component)) + ]) + ) + (prop (vcomponent type: 'VTIMEZONE) 'TZID zone-name) + (filter (relevant-zone-entry? event) (get-zone zoneinfo zone-name)) + )) diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index 736db0a4..1226fc44 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -73,7 +73,7 @@ (let ((s (prop ev 'DTSTART)) (e (prop ev 'DTEND))) (if e - (let ((fmt-str (if (date= (get-date s) (get-date e)) + (let ((fmt-str (if (date= (datetime-date s) (datetime-date e)) (G_ "~H:~M") ;; Note the non-breaking space (G_ "~Y-~m-~d ~H:~M")))) diff --git a/module/vcomponent/formats/ical.scm b/module/vcomponent/formats/ical.scm new file mode 100644 index 00000000..dddca946 --- /dev/null +++ b/module/vcomponent/formats/ical.scm @@ -0,0 +1,17 @@ +(define-module (vcomponent formats ical) + :use-module ((vcomponent formats ical output) + :select (component->ical-string)) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar)) + :export (serialize + deserialize + ) + ) + + +(define (serialize component port) + (with-output-to-port port + (lambda () (component->ical-string component)))) + +(define (deserialize port) + (parse-calendar port)) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index 4d37dff6..5fa004bb 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -14,8 +14,10 @@ :use-module (vcomponent) :use-module (vcomponent datetime) :use-module (vcomponent geo) - :use-module (vcomponent formats ical types) + :use-module ((vcomponent formats ical types) + :select (escape-chars get-writer)) :use-module (vcomponent recurrence) + :use-module ((calp) :select (prodid)) :use-module (calp translation) :autoload (vcomponent util instance) (global-event-object) :export (component->ical-string @@ -24,10 +26,6 @@ print-events-in-interval )) -(define (prodid) - (format #f "-//hugo//calp ~a//EN" - (@ (calp) version))) - ;; Format value depending on key type. ;; Should NOT emit the key. @@ -101,11 +99,12 @@ (catch #t #; 'wrong-type-arg (lambda () - (writer ((@@ (vcomponent base) get-vline-parameters) vline) - (value vline))) + (writer + (vline-parameters vline) + (vline-value vline))) (lambda (err caller fmt args call-args) (define fallback-string - (with-output-to-string (lambda () (display value)))) + (with-output-to-string (lambda () (display (vline-value vline))))) (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s" key caller call-args fmt args fallback-string) @@ -129,11 +128,10 @@ (define (vline->string vline) - (define key (vline-key vline)) (ical-line-fold ;; Expected output: key;p1=v;p3=10:value (string-append - (symbol->string key) + (symbol->string (key vline)) (string-concatenate (map (match-lambda [(? (compose internal-field? car)) ""] @@ -143,7 +141,7 @@ (string-join (map (compose escape-chars ->string) values) "," 'infix))]) (parameters vline))) - ":" (value-format key vline)))) + ":" (value-format (key vline) vline)))) (define (component->ical-string component) (format #t "BEGIN:~a\r\n" (type component)) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 252a155e..38257fba 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -1,6 +1,7 @@ (define-module (vcomponent formats ical parse) :use-module ((ice-9 rdelim) :select (read-line)) :use-module (ice-9 format) + :use-module (ice-9 curried-definitions) :use-module (hnh util exceptions) :use-module (hnh util) :use-module (datetime) @@ -12,6 +13,8 @@ :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (calp translation) + :use-module (hnh util lens) + :use-module (hnh util table) :export (parse-calendar)) ;;; TODO a few translated strings here contain explicit newlines. Check if that @@ -139,7 +142,7 @@ (define (build-vline key value params) (let ((parser (cond - [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] + [(and=> (table-get params 'VALUE) string->symbol) => get-parser] [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE CREATED DTSTAMP LAST-MODIFIED @@ -246,9 +249,9 @@ (let ((parsed (parser params value))) (if (list? parsed) (apply values - (map (lambda (p) (make-vline key p params)) + (map (lambda (p) (vline key: key vline-value: p vline-parameters: params)) parsed)) - (make-vline key parsed params))))) + (vline key: key vline-value: parsed vline-parameters: params))))) ;; (parse-itemline '("DTEND" "20200407T130000")) ;; => DTEND @@ -256,17 +259,45 @@ ;; => #<hash-table 7f76b5f82a60 0/31> (define (parse-itemline itemline) (define key (string->symbol (car itemline))) - (define parameters (make-hash-table)) - (let loop ((rem (cdr itemline))) - (if (null? (cdr rem)) - (values key (car rem) parameters ) - (let* ((kv (car rem)) - (idx (string-index kv #\=))) - ;; TODO lists in parameters - (hashq-set! parameters (string->symbol (substring kv 0 idx)) - (substring kv (1+ idx))) - (loop (cdr rem)))))) - + ;; (define parameters (make-hash-table)) + (define-values (parameters value) (init+last (cdr itemline))) + (values + key value + (fold (lambda (parameter table) + (let ((idx (string-index parameter #\=))) + ;; TODO lists in parameters + (table-put table (string->symbol (substring parameter 0 idx)) + (substring parameter (1+ idx))))) + (table) + parameters))) + +(define ((warning-handler-proc token) fmt . args) + (let ((linedata (get-metadata token))) + (format + #f + ;; arguments: + ;; linedata + ;; ~? + ;; source line + ;; source file + (G_ "WARNING parse error around ~a + ~? + line ~a ~a~%") + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata) + ))) + +;;; Property keys which are allowed multiple times +(define repeating-properties + '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) ;; (list <tokens>) → <vcomponent> (define (parse lst) @@ -274,69 +305,53 @@ (stack '())) (if (null? lst) stack - (let* ((head* (car lst)) - (head (get-data head*))) + (let* ((token (car lst)) + (head (get-data token))) (catch 'parse-error (lambda () - (parameterize - ((warning-handler - (lambda (fmt . args) - (let ((linedata (get-metadata head*))) - (format - #f - ;; arguments: - ;; linedata - ;; ~? - ;; source line - ;; source file - (G_ "WARNING parse error around ~a - ~? - line ~a ~a~%") - (get-string linedata) - fmt args - (get-line linedata) - (get-file linedata) - ))))) - (cond [(string=? "BEGIN" (car head)) - (loop (cdr lst) - (cons (make-vcomponent (string->symbol (cadr head))) - stack))] - [(string=? "END" (car head)) - (loop (cdr lst) - (if (null? (cdr stack)) - ;; return - (car stack) - (begin (add-child! (cadr stack) (car stack)) - (cdr stack))))] - [else - (let ((key value params (parse-itemline head))) - (call-with-values (lambda () (build-vline key value params)) - (lambda vlines - (for vline in vlines - (define key (vline-key vline)) - - (set! (vline-source vline) - (get-metadata head*)) + (parameterize ((warning-handler (warning-handler-proc token))) + (cond [(string=? "BEGIN" (car head)) + (format (current-error-port) "BEGIN ~s~%" (cadr head)) + (loop (cdr lst) + (cons (vcomponent type: (string->symbol (cadr head))) + stack))] + [(string=? "END" (car head)) + (format (current-error-port) "END ~s~%" (cadr head)) + (loop (cdr lst) + (if (null? (cdr stack)) + ;; return + stack + (cons (add-child (cadr stack) (car stack)) + (cddr stack))))] + [else + (let ((k value params (parse-itemline head))) + (loop (cdr lst) + (let (((values . vlines) (build-vline k value params))) + ;; TODO + ;; (set! (vline-source vline) + ;; (get-metadata token)) ;; See RFC 5545 p.53 for list of all repeating types ;; (for vcomponent) - ;; TODO templetize this, and allow users to set which types are list types, but also validate this upon creation (elsewhere) - (if (memv key '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* (car stack) key) - (set! (prop* (car stack) key) (cons vline it)) - (set! (prop* (car stack) key) (list vline))) - ;; else - (set! (prop* (car stack) key) vline)))))) - - (loop (cdr lst) stack)]))) + ;; TODO templetize this, and allow users to + ;; set which types are list types, but also + ;; validate this upon creation (elsewhere). + (fold (lambda (vline stack) + (modify stack car* + (lambda (comp) + (format (current-error-port) + " stack=~s, comp=~s~%" + stack comp) + (if (memv (key vline) repeating-properties) + (aif (prop* comp (key vline)) + (prop* comp (key vline) (cons vline it)) + (prop* comp (key vline) (list vline))) + ;; else + (prop* comp (key vline) vline))))) + stack vlines))))]))) + (lambda (err proc fmt fmt-args data) - (let ((linedata (get-metadata head*))) + (let ((linedata (get-metadata token))) (display (format #f ;; arguments @@ -353,7 +368,10 @@ (get-line linedata) (get-file linedata)) (current-error-port)) - (let ((key value params (parse-itemline head))) - (set! (prop* (car stack) key) - (make-vline key value params)) - (loop (cdr lst) stack))))))))) + (let ((k value params (parse-itemline head))) + (loop (cdr lst) + (modify stack car* + (lambda (c) (prop* c key + (vline key: k + vline-value: value + vline-parameters: params))))))))))))) diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm index 768f5098..c5259f0d 100644 --- a/module/vcomponent/formats/ical/types.scm +++ b/module/vcomponent/formats/ical/types.scm @@ -2,6 +2,7 @@ (define-module (vcomponent formats ical types) :use-module (hnh util) :use-module (hnh util exceptions) + :use-module (hnh util table) :use-module (base64) :use-module (datetime) :use-module (datetime timespec) @@ -23,7 +24,8 @@ ;; NOTE We really should output TZID from param here, but ;; we first need to change so these writers can output ;; parameters. - (datetime->string (hashq-ref param '-X-HNH-ORIGINAL value) + (datetime->string (or (table-get param '-X-HNH-ORIGINAL) + value) "~Y~m~dT~H~M~S~Z")) (define (write-duration _ value) diff --git a/module/vcomponent/formats/sxcal.scm b/module/vcomponent/formats/sxcal.scm new file mode 100644 index 00000000..c02dbada --- /dev/null +++ b/module/vcomponent/formats/sxcal.scm @@ -0,0 +1,16 @@ +(define-module (vcomponent formats sxcal) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :export (serialize deserialize) + ) + + +(define (serialize component port) + (write (serialize/object component) port)) + +(define (serialize/object component) + ;; TODO where is this defined? + (vcomponent->sxcal component)) + +(define (deserialize port) + (sxcal->vcomponent port)) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 4e21d4d0..7f1439ae 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -44,13 +44,14 @@ (partition (lambda (e) (eq? 'VEVENT (type e))) (children item))) - (unless (eq? 'VCALENDAR (type item)) (scm-error 'misc-error "parse-vdir" "Unexepected top level component. Expected VCALENDAR, got ~a. In file ~s" (list (type item) (prop item '-X-HNH-FILENAME)) #f)) + ;; TODO + #; (for child in (children item) (set! (prop child '-X-HNH-FILENAME) (prop (parent child) '-X-HNH-FILENAME))) @@ -65,8 +66,9 @@ ;; the standard. Section 3.8.4.4. (case (length events) [(0) (warning (G_ "No events in component~%~a") - (prop item '-X-HNH-FILENAME))] - [(1) (add-child! calendar (car events))] + (prop item '-X-HNH-FILENAME)) + calendar] + [(1) (add-child calendar (car events))] ;; two or more [else @@ -93,35 +95,36 @@ (car events))) (rest (delete head events eq?))) - (set! (prop head '-X-HNH-ALTERNATIVES) - (alist->hash-table - (map cons - ;; head is added back to the collection to simplify - ;; generation of recurrences. The recurrence - ;; generation assumes that the base event either - ;; contains an RRULE property, OR is in the - ;; -X-HNH-ALTERNATIVES set. This might produce - ;; duplicates, since the base event might also - ;; get included through an RRULE. This however - ;; is almost a non-problem, since RDATES and RRULES - ;; can already produce duplicates, meaning that - ;; we need to filter duplicates either way. - (map (extract 'RECURRENCE-ID) (cons head rest)) - (cons head rest)))) - (add-child! calendar head))]) + (add-child + calendar + ;; TODO this is really ugly + (prop head '-X-HNH-ALTERNATIVES + (alist->hash-table + (map cons + ;; head is added back to the collection to simplify + ;; generation of recurrences. The recurrence + ;; generation assumes that the base event either + ;; contains an RRULE property, OR is in the + ;; -X-HNH-ALTERNATIVES set. This might produce + ;; duplicates, since the base event might also + ;; get included through an RRULE. This however + ;; is almost a non-problem, since RDATES and RRULES + ;; can already produce duplicates, meaning that + ;; we need to filter duplicates either way. + (map (extract 'RECURRENCE-ID) (cons head rest)) + (cons head rest))))))]) ;; return calendar) - (make-vcomponent) + (vcomponent type: 'VIRTUAL) (map #; (@ (ice-9 threads) par-map) (lambda (fname) (let ((fullname (path-append path fname))) - (let ((cal (call-with-input-file fullname - parse-calendar))) - (set! (prop cal 'COLOR) color - (prop cal 'NAME) name - (prop cal '-X-HNH-FILENAME) fullname) - cal))) + (set-properties (call-with-input-file fullname + parse-calendar) + (cons 'COLOR color) + (cons 'NAME name) + (cons '-X-HNH-FILENAME fullname)))) (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) (string= "ics" (string-take-right s 3))))))))) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index ab1985b6..d096405e 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -61,4 +61,4 @@ (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) (delete-file (prop event '-X-HNH-FILENAME)) - (remove-child! parent event)) + (abandon! parent event)) diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm new file mode 100644 index 00000000..29a1d92f --- /dev/null +++ b/module/vcomponent/formats/xcal.scm @@ -0,0 +1,27 @@ +(define-module (vcomponent formats xcal) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module ((vcomponent formats xcal output) + :select (vcomponent->sxcal ns-wrap)) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :use-module ((hnh util) :select (->)) + :export (serialize deserialize)) + + +(define* (serialize component port key: (namespaces '())) + (-> (vcomponent->sxcal component) + ns-wrap + (namespaced-sxml->xml port: port + namespaces: namespaces))) + +(define (serialize/object component) + (call-with-output-string (lambda (p) (serialize component p)))) + + +(define* (deserialize port) + (-> port + xml->namespaced-sxml + root-element ; Strip potential *TOP* + cadr ; Remove containing icalendar + sxcal->vcomponent)) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index 8e92b280..7cf8c591 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -8,28 +8,31 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (calp translation) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :export (vcomponent->sxcal ns-wrap)) (define (vline->value-tag vline) - (define key (vline-key vline)) + (define k (key vline)) (define writer (cond [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer] - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID + [(memv k '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID CREATED DTSTAMP LAST-MODIFIED ACKNOWLEDGED EXDATE)) (get-writer 'DATE-TIME)] - [(memv key '(TRIGGER DURATION)) + [(memv k '(TRIGGER DURATION)) (get-writer 'DURATION)] - [(memv key '(FREEBUSY)) + [(memv k '(FREEBUSY)) (get-writer 'PERIOD)] - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + [(memv k '(CALSCALE METHOD PRODID COMMENT DESCRIPTION LOCATION SUMMARY TZID TZNAME CONTACT RELATED-TO UID @@ -38,69 +41,69 @@ VERSION)) (get-writer 'TEXT)] - [(memv key '(TRANSP + [(memv k '(TRANSP CLASS PARTSTAT STATUS ACTION)) (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] - [(memv key '(TZOFFSETFROM TZOFFSETTO)) + [(memv k '(TZOFFSETFROM TZOFFSETTO)) (get-writer 'UTC-OFFSET)] - [(memv key '(ATTACH TZURL URL)) + [(memv k '(ATTACH TZURL URL)) (get-writer 'URI)] - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + [(memv k '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) (get-writer 'INTEGER)] - [(memv key '(GEO)) + [(memv k '(GEO)) (lambda (_ v) - `(geo + `(,(xml xcal 'geo) (latitude ,(geo-latitude v)) (longitude ,(geo-longitude v))))] - [(memv key '(RRULE)) + [(memv k '(RRULE)) (get-writer 'RECUR)] - [(memv key '(ORGANIZER ATTENDEE)) + [(memv k '(ORGANIZER ATTENDEE)) (get-writer 'CAL-ADDRESS)] - [(x-property? key) + [(x-property? k) (get-writer 'TEXT)] [else - (warning (G_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") k) (get-writer 'TEXT)])) - (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) + (writer ((@@ (vcomponent base) get-vline-parameters) vline) + (value vline))) (define (property->value-tag tag . values) (if (or (eq? tag 'VALUE) (internal-field? tag)) #f - `(,(downcase-symbol tag) + `(,(xml xcal (downcase-symbol tag)) ,@(map (lambda (v) ;; TODO parameter types!!!! (rfc6321 3.5.) - `(text ,(->string v))) + `(,(xml xcal 'text) ,(->string v))) values)))) ;; ((key value ...) ...) -> `(parameters , ... ) (define (parameters-tag parameters) (define outparams (filter-map - (lambda (x) (apply property->value-tag x)) + (lambda (x) (property->value-tag x)) parameters)) (unless (null? outparams) - `(parameters ,@outparams))) + `(,(xml xcal 'parameters) ,@outparams))) (define (vcomponent->sxcal component) (define tagsymb (downcase-symbol (type component))) - (remove null? - `(,tagsymb + `(,(xml xcal tagsymb) ;; only have <properties> when it's non-empty. ,(let ((props (filter-map @@ -108,27 +111,33 @@ [(? (compose internal-field? car)) #f] [(key vlines ...) + (format (current-error-port) "vlines: ~s~%" vlines) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (reduce assq-merge - '() (map parameters vlines))) + '() + (map parameters vlines))) ,@(for vline in vlines (vline->value-tag vline))))] [(key . vline) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (parameters vline)) ,(vline->value-tag vline)))]) - (properties component)))) + ;; NOTE this sort is unnecesasary, but here so tests can work + ;; Possibly add it as a flag instead + (sort* (properties component) + string< (compose symbol->string car))))) (unless (null? props) - `(properties + `(,(xml xcal 'properties) ;; NOTE ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) ,@props))) ,(unless (null? (children component)) - `(components ,@(map vcomponent->sxcal (children component))))))) + `(,(xml xcal 'components) + ,@(map vcomponent->sxcal (children component))))))) (define (ns-wrap sxml) - `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) - ,sxml)) + `(,(xml xcal 'icalendar) + ,sxml)) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 0e638d36..5ae1b928 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -3,18 +3,24 @@ :use-module (hnh util exceptions) :use-module (base64) :use-module (ice-9 match) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :use-module (sxml match) :use-module (vcomponent) :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (datetime) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) :use-module (calp translation) + :use-module (hnh util table) :export (sxcal->vcomponent) ) ;; symbol, ht, (list a) -> non-list -(define (handle-value type props value) +(define (handle-value type parameters value) (case type [(binary) @@ -25,17 +31,17 @@ [(boolean) (string=? "true" (car value))] ;; TODO possibly trim whitespace on text fields - [(cal-address uri text unknown) (car value)] + [(cal-address uri text unknown) (string-concatenate value)] [(date) ;; TODO this is correct, but ensure remaining types - (hashq-set! props 'VALUE "DATE") + (hashq-set! parameters 'VALUE "DATE") (parse-iso-date (car value))] [(date-time) (parse-iso-datetime (car value))] [(duration) - ((get-parser 'DURATION) props value)] + ((get-parser 'DURATION) parameters value)] [(float integer) ; (3.0) (string->number (car value))] @@ -96,35 +102,39 @@ (for key in '(bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos freq until count interval wkst) - (define values (assoc-ref-all value key)) - (if (null? values) - #f - (case key - ;; These fields all have zero or one value - ((freq until count interval wkst) - (list (symbol->keyword key) - (parse-value-of-that-type - key (car (map car values))))) - ;; these fields take lists - ((bysecond byminute byhour byday bymonthday - byyearday byweekno bymonth bysetpos) - (list (symbol->keyword key) - (map (lambda (v) (parse-value-of-that-type key v)) - (map car values)))) - (else (scm-error 'misc-error "handle-value" - "Invalid key ~s" - (list key) - #f)))))))))] + (cond ((find-element (xml xcal key) value) + => (lambda (v) + (case key + ;; These fields all have zero or one value + ((freq until count interval wkst) + (list (symbol->keyword key) + (parse-value-of-that-type + key (cadr v)))) + ;; these fields take lists + ((bysecond byminute byhour byday bymonthday + byyearday byweekno bymonth bysetpos) + (list (symbol->keyword key) + (map (lambda (v) (parse-value-of-that-type key v)) + (cadr v)))) + (else (scm-error 'misc-error "handle-value" + "Invalid key ~s" + (list key) + #f))))) + (else #f)))))))] [(time) (parse-iso-time (car value))] - [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] + [(utc-offset) ((get-parser 'UTC-OFFSET) parameters (car value))] [(geo) ; ((long 1) (lat 2)) (sxml-match (cons 'geo value) [(geo (latitude ,x) (longitude ,y)) - ((@ (vcomponent geo) make-geo) x y)])])) + ((@ (vcomponent geo) make-geo) x y)])] + + [else (scm-error 'misc-error "handle-value" + "Unknown value type: ~s" + (list type) #f)])) (define (symbol-upcase symb) (-> symb @@ -134,16 +144,20 @@ (define (handle-parameters parameters) - (define ht (make-hash-table)) + ;; (assert (element-matches? (xml xcal 'parameters) + ;; parameters)) - (for param in parameters - (match param - [(ptag (ptype pvalue ...) ...) - ;; TODO parameter type (rfc6321 3.5.) + (fold (lambda (param table) + (define ptag (xml-element-tagname (car param))) + ;; (define-values (ptype pvalue) (car+cdr cdr)) ;; TODO multi-valued parameters!!! - (hashq-set! ht (symbol-upcase ptag) - (car (concatenate pvalue)))])) - ht) + (define-values (pytpe pvalue) (car+cdr (cadr param))) + ;; TODO parameter type (rfc6321 3.5.) + ;; TODO namespaces + (table-put table (symbol-upcase ptag) + (concatenate pvalue))) + (table) + (cdr parameters))) (define* (parse-enum str enum optional: (allow-other #t)) (let ((symb (string->symbol str))) @@ -153,7 +167,8 @@ ;; symbol non-list -> non-list -(define (handle-tag tag-name data) +(define (handle-tag xml-tag data) + (define tag-name (xml-element-tagname xml-tag)) (case tag-name [(request-status) ;; TODO @@ -174,6 +189,51 @@ data '(AUDIO DISPLAY EMAIL NONE))) [else data])) +(define (handle-single-property component tree) + (define xml-tag (car tree)) + (define tag (xml-element-tagname xml-tag)) + (define tag* (symbol-upcase tag)) + + (define body (cdr tree)) + + ;; TODO request-status + (define-values (parameters data) + (if (element-matches? (xml xcal 'parameters) + (car body)) + (values (handle-parameters (car body)) + (cdr body)) + (values (make-hash-table) + body))) + + (fold (lambda (typetag component) + (define type (xml-element-tagname (car typetag))) + ;; TODO multi valued data + (define raw-value (cdr typetag)) + (define vline* + (vline type: tag* + value: (handle-tag + xml-tag + (let ((v (handle-value type parameters raw-value))) + ;; TODO possibly more list fields + ;; (if (eq? tag 'categories) + ;; (string-split v #\,) + ;; v) + + v)) + parameters: parameters)) + (if (memv tag* '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* component tag*) + (prop* component tag* (cons vline* it)) + (prop* component tag* (list vline*))) + (prop* component tag* vline*))) + component data)) + ;; Note ;; This doesn't verify the inter-field validity of the object, ;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME @@ -181,83 +241,30 @@ ;; TODO ;; since we are feeding user input into this it really should be fixed. (define (sxcal->vcomponent sxcal) - (define type (symbol-upcase (car sxcal))) - (define component (make-vcomponent type)) - - (awhen (assoc-ref sxcal 'properties) - ;; Loop over multi valued fields, creating one vline - ;; for every value. So - ;; KEY;p=1:a,b - ;; would be expanded into - ;; KEY;p=1:a - ;; KEY;p=1:b - (for property in it - (match property - ;; TODO request-status - - [(tag ('parameters parameters ...) - (type value ...) ...) - (let ((params (handle-parameters parameters)) - (tag* (symbol-upcase tag))) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let () - (define vline - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params)) - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - ))))] - - [(tag (type value ...) ...) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let ((params (make-hash-table)) - (tag* (symbol-upcase tag))) - (define vline - (make-vline tag* - (handle-tag - tag (let ((v (handle-value type params value))) - ;; TODO possibly more list fields - (if (eq? tag 'categories) - (string-split v #\,) - v))) - params)) - ;; - - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - )))]))) - - ;; children - (awhen (assoc-ref sxcal 'components) - (for child in (map sxcal->vcomponent it) - (add-child! component child))) - - component) + + ;; TODO the surrounding icalendar element needs to be removed BEFORE this procedue is called + + (define xml-tag (car sxcal)) + (define type (symbol-upcase (xml-element-tagname xml-tag))) + + (let ((component + (aif (find-element (xml xcal 'properties) (cdr sxcal)) + ;; Loop over multi valued fields, creating one vline + ;; for every value. So + ;; KEY;p=1:a,b + ;; would be expanded into + ;; KEY;p=1:a + ;; KEY;p=1:b + (fold swap handle-single-property + (vcomponent type: type) (cdr it)) + (vcomponent type: type)))) + + ;; children + (aif (find-element (xml xcal 'components) (cdr sxcal)) + ;; NOTE Order of children is insignificant, but this allows + ;; diffs to be stable (which is used by the format tests). + (fold (swap add-child) + component + (map sxcal->vcomponent + (reverse (cdr it)))) + component))) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index 024ca61a..82121d5e 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -3,16 +3,18 @@ :use-module (vcomponent formats ical types) :use-module (datetime) :use-module (calp translation) + :use-module ((calp namespaces) :select (xcal)) + :use-module ((sxml namespaced) :select (xml)) :export (get-writer)) (define (write-boolean _ v) - `(boolean ,(if v "true" "false"))) + `(,(xml xcal 'boolean) ,(if v "true" "false"))) (define (write-date _ v) - `(date ,(date->string v "~Y-~m-~d"))) + `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d"))) (define (write-datetime p v) - `(date-time + `(,(xml xcal 'date-time) ,(datetime->string (hashq-ref p '-X-HNH-ORIGINAL v) ;; 'Z' should be included for UTC, @@ -21,17 +23,17 @@ "~Y-~m-~dT~H:~M:~S~Z"))) (define (write-time _ v) - `(time ,(time->string v "~H:~M:S"))) + `(,(xml xcal 'time) ,(time->string v "~H:~M:S"))) (define (write-recur _ v) - `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) + `(,(xml xcal 'recur) ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) ;; sepparate since this text shouldn't be escaped (define (write-text _ v) ;; TODO out type should be xsd:string. ;; Look into what that means, and escape ;; from there - `(text ,v)) + `(,(xml xcal 'text) ,v)) @@ -40,7 +42,7 @@ #| TODO PERIOD |# URI UTC-OFFSET) (hashq-set! sxml-writers simple-type (lambda (p v) - `(,(downcase-symbol simple-type) + `(,(xml xcal (downcase-symbol simple-type)) ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v))))) (hashq-set! sxml-writers 'BOOLEAN write-boolean) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 07305647..936c2631 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -119,7 +119,7 @@ (branching-fold (lambda (rule dt) (let* ((key value (car+cdr rule)) - (d (if (date? dt) dt (get-date dt))) + (d (if (date? dt) dt (datetime-date dt))) ;; NOTE It's proably an error to give BYHOUR, BYMINUTE, and BYSECOND ;; rules for a date object. This doesn't warn if those are given, but ;; instead silently discards them. @@ -128,8 +128,8 @@ (if (date? dt) (if (date? o) o d) (if (date? o) - (datetime date: o time: t tz: (get-timezone dt)) - (datetime date: d time: o tz: (get-timezone dt))))))) + (datetime date: o time: t tz: (tz dt)) + (datetime date: d time: o tz: (tz dt))))))) (case key [(BYMONTH) (if (and (eq? 'YEARLY (freq rrule)) @@ -141,11 +141,11 @@ (concatenate (map (lambda (wday) (all-wday-in-month - wday (start-of-month (set (month d) value)))) + wday (start-of-month (month d value)))) (map cdr (byday rrule))))) ;; else - (to-dt (set (month d) value)))] + (to-dt (month d value)))] [(BYDAY) (let* ((offset value (car+cdr value))) @@ -201,12 +201,12 @@ [(BYYEARDAY) (to-dt (date+ (start-of-year d) (date day: (1- value))))] [(BYMONTHDAY) - (to-dt (set (day d) + (to-dt (day d (if (positive? value) value (+ 1 value (days-in-month d)))))] - [(BYHOUR) (to-dt (set (hour t) value))] - [(BYMINUTE) (to-dt (set (minute t) value))] - [(BYSECOND) (to-dt (set (second t) value))] + [(BYHOUR) (to-dt (hour t value))] + [(BYMINUTE) (to-dt (minute t value))] + [(BYSECOND) (to-dt (second t value))] [else (scm-error 'wrong-type-arg "update" "Unrecognized by-extender ~s" key #f)]))) @@ -254,7 +254,7 @@ (extend-recurrence-set rrule (if (date? base-date) - (date+ base-date (get-date (make-date-increment rrule))) + (date+ base-date (datetime-date (make-date-increment rrule))) (datetime+ base-date (make-date-increment rrule)))))) (define ((month-mod d) value) @@ -273,7 +273,7 @@ #t (let ((key values (car+cdr (car remaining))) (t (as-time dt)) - (d (if (date? dt) dt (get-date dt)))) + (d (if (date? dt) dt (datetime-date dt)))) (and (case key [(BYMONTH) (memv (month d) values)] [(BYMONTHDAY) (memv (day d) (map (month-mod d) values))] @@ -339,10 +339,10 @@ (rrule-instances-raw rrule (prop event 'DTSTART)))) (else stream-null))) (rdates - (cond ((prop* event 'RDATE) => (lambda (v) (map value v))) + (cond ((prop* event 'RDATE) => (lambda (v) (map vline-value v))) (else '()))) (exdates - (cond ((prop* event 'EXDATE) => (lambda (v) (map value v))) + (cond ((prop* event 'EXDATE) => (lambda (v) (map vline-value v))) (else #f)))) (let ((items (interleave-streams @@ -418,21 +418,19 @@ => (lambda (ht) (aif (hash-ref ht dt) it ; RECURRENCE-ID objects come with their own DTEND - (let ((ev (copy-vcomponent base-event))) - (set! (prop ev 'DTSTART) dt) - (when duration ; (and (not (prop ev 'DTEND)) duration) - ;; p. 123 (3.8.5.3 Recurrence Rule) - ;; specifies that the DTEND should be updated to match how the - ;; initial dtend related to the initial DTSTART. It also notes - ;; that an event of 1 day in length might be longer or shorter - ;; than 24h depending on timezone shifts. - (set! (prop ev 'DTEND) (get-endtime dt duration))) - ev)))) + (let ((ev (prop base-event 'DTSTART dt))) + (if duration ; (and (not (prop ev 'DTEND)) duration) + ;; p. 123 (3.8.5.3 Recurrence Rule) + ;; specifies that the DTEND should be updated to match how the + ;; initial dtend related to the initial DTSTART. It also notes + ;; that an event of 1 day in length might be longer or shorter + ;; than 24h depending on timezone shifts. + (prop ev 'DTEND (get-endtime dt duration)) + ev))))) (else - (let ((ev (copy-vcomponent base-event))) - (set! (prop ev 'DTSTART) dt) - (when duration - (set! (prop ev 'DTEND) (get-endtime dt duration))) - ev)))) + (let ((ev (prop base-event 'DTSTART dt))) + (if duration + (prop ev 'DTEND (get-endtime dt duration)) + ev))))) rrule-stream)) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 5651b265..fef83958 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -96,7 +96,7 @@ type (concatenate (map children (slot-ref this 'calendars))))) (events (awhen (assoc-ref groups 'VEVENT) - (car it))) + it)) (removed remaining (partition (extract 'X-HNH-REMOVED) events))) ;; TODO figure out what to do with removed events @@ -125,7 +125,7 @@ ;;; with the same UID, which is BAD. (define-method (add-event (this <events>) calendar event) - (add-child! calendar event) + (reparent! calendar event) (unless (prop event 'UID) (set! (prop event 'UID) (uuid))) @@ -184,7 +184,7 @@ ;; remove old instance of event from runtime (remove-event this old-event) - (remove-child! old-calendar old-event) + (abandon! old-calendar old-event) ;; Add new event to runtime, ;; MUST be done after since the two events SHOULD share UID. diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index 24eee04e..33dbd0cc 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -1,3 +1,5 @@ +;;; TODO remove this module, it should be part of the vdir interface + (define-module (vcomponent util parse-cal-path) :use-module (hnh util) :use-module ((calp util time) :select (report-time!)) @@ -17,24 +19,21 @@ (define cal (case (stat:type st) [(regular) - (let ((comp (call-with-input-file path parse-calendar))) - (set! (prop comp '-X-HNH-SOURCETYPE) 'file) - comp) ] + (prop (call-with-input-file path parse-calendar) + '-X-HNH-SOURCETYPE 'file)] [(directory) (report-time! (G_ "Parsing ~a") path) - (let ((comp (parse-vdir path))) - (set! (prop comp '-X-HNH-SOURCETYPE) 'vdir - (prop comp '-X-HNH-DIRECTORY) path) - comp)] + (set-properties (parse-vdir path) + (cons '-X-HNH-SOURCETYPE 'vdir) + (cons '-X-HNH-DIRECTORY path))] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (scm-error 'misc-error "parse-cal-path" (G_ "Can't parse file of type ~s") (list t) #f))])) - (unless (prop cal "NAME") - (set! (prop cal "NAME") - (or (prop cal "X-WR-CALNAME") - (string-append "[" (basename path) "]")))) - - cal) + (if (prop cal 'NAME) + cal + (prop cal 'NAME + (or (prop cal 'X-WR-CALNAME) + (string-append "[" (basename path) "]"))))) diff --git a/module/web/http.scm b/module/web/http.scm new file mode 100644 index 00000000..62a462d3 --- /dev/null +++ b/module/web/http.scm @@ -0,0 +1,2081 @@ +;;; HTTP messages + +;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;; Copyright (C) 2023 Hugo Hörnquist. + +;;; Commentary: +;;; +;;; This module has a number of routines to parse textual +;;; representations of HTTP data into native Scheme data structures. +;;; +;;; It tries to follow RFCs fairly strictly---the road to perdition +;;; being paved with compatibility hacks---though some allowances are +;;; made for not-too-divergent texts (like a quality of .2 which should +;;; be 0.2, etc). +;;; +;;; Code: + +(define-module (web http) + #:use-module ((srfi srfi-1) #:select (append-map! map! find)) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 q) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 exceptions) + #:use-module (rnrs bytevectors) + #:use-module (web uri) + #:export (string->header + header->string + + declare-header! + declare-opaque-header! + known-header? + header-parser + header-validator + header-writer + + read-header + parse-header + valid-header? + write-header + + read-headers + write-headers + + declare-method! + parse-http-method + parse-http-version + parse-request-uri + + read-request-line + write-request-line + read-response-line + write-response-line + + &chunked-input-error-prematurely + chunked-input-ended-prematurely-error? + make-chunked-input-port + make-chunked-output-port + + http-proxy-port? + set-http-proxy-port?!)) + + +(define (put-symbol port sym) + (put-string port (symbol->string sym))) + +(define (put-non-negative-integer port i) + (put-string port (number->string i))) + +(define (string->header name) + "Parse NAME to a symbolic header name." + (string->symbol (string-downcase name))) + +(define-record-type <header-decl> + (make-header-decl name parser validator writer multiple?) + header-decl? + (name header-decl-name) + (parser header-decl-parser) + (validator header-decl-validator) + (writer header-decl-writer) + (multiple? header-decl-multiple?)) + +;; sym -> header +(define *declared-headers* (make-hash-table)) + +(define (lookup-header-decl sym) + (hashq-ref *declared-headers* sym)) + +(define* (declare-header! name + parser + validator + writer + #:key multiple?) + "Declare a parser, validator, and writer for a given header." + (unless (and (string? name) parser validator writer) + (error "bad header decl" name parser validator writer multiple?)) + (let ((decl (make-header-decl name parser validator writer multiple?))) + (hashq-set! *declared-headers* (string->header name) decl) + decl)) + +(define (header->string sym) + "Return the string form for the header named SYM." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-name decl) + (string-titlecase (symbol->string sym))))) + +(define (known-header? sym) + "Return ‘#t’ iff SYM is a known header, with associated +parsers and serialization procedures." + (and (lookup-header-decl sym) #t)) + +(define (header-parser sym) + "Return the value parser for headers named SYM. The result is a +procedure that takes one argument, a string, and returns the parsed +value. If the header isn't known to Guile, a default parser is returned +that passes through the string unchanged." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-parser decl) + (lambda (x) x)))) + +(define (header-validator sym) + "Return a predicate which returns ‘#t’ if the given value is valid +for headers named SYM. The default validator for unknown headers +is ‘string?’." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-validator decl) + string?))) + +(define (header-writer sym) + "Return a procedure that writes values for headers named SYM to a +port. The resulting procedure takes two arguments: a value and a port. +The default writer will call ‘put-string’." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-writer decl) + (lambda (val port) + (put-string port val))))) + +(define (read-header-line port) + "Read an HTTP header line and return it without its final CRLF or LF. +Raise a 'bad-header' exception if the line does not end in CRLF or LF, +or if EOF is reached." + (match (%read-line port) + (((? string? line) . #\newline) + ;; '%read-line' does not consider #\return a delimiter; so if it's + ;; there, remove it. We are more tolerant than the RFC in that we + ;; tolerate LF-only endings. + (if (string-suffix? "\r" line) + (string-drop-right line 1) + line)) + ((line . _) ;EOF or missing delimiter + (bad-header 'read-header-line line)))) + +(define (read-continuation-line port val) + (match (peek-char port) + ((or #\space #\tab) + (read-continuation-line port + (string-append val (read-header-line port)))) + (_ val))) + +(define *eof* (call-with-input-string "" read)) + +(define (read-header port) + "Read one HTTP header from PORT. Return two values: the header +name and the parsed Scheme value. May raise an exception if the header +was known but the value was invalid. + +Returns the end-of-file object for both values if the end of the message +body was reached (i.e., a blank line)." + (let ((line (read-header-line port))) + (if (or (string-null? line) + (string=? line "\r")) + (values *eof* *eof*) + (let* ((delim (or (string-index line #\:) + (bad-header '%read line))) + (sym (string->header (substring line 0 delim)))) + (values + sym + (parse-header + sym + (read-continuation-line + port + (string-trim-both line char-set:whitespace (1+ delim))))))))) + +(define (parse-header sym val) + "Parse VAL, a string, with the parser registered for the header +named SYM. Returns the parsed value." + ((header-parser sym) val)) + +(define (valid-header? sym val) + "Returns a true value iff VAL is a valid Scheme value for the +header with name SYM." + (unless (symbol? sym) + (error "header name not a symbol" sym)) + ((header-validator sym) val)) + +(define (write-header sym val port) + "Write the given header name and value to PORT, using the writer +from ‘header-writer’." + (put-string port (header->string sym)) + (put-string port ": ") + ((header-writer sym) val port) + (put-string port "\r\n")) + +(define (read-headers port) + "Read the headers of an HTTP message from PORT, returning them +as an ordered alist." + (let lp ((headers '())) + (call-with-values (lambda () (read-header port)) + (lambda (k v) + (if (eof-object? k) + (reverse! headers) + (lp (acons k v headers))))))) + +(define (write-headers headers port) + "Write the given header alist to PORT. Doesn't write the final +‘\\r\\n’, as the user might want to add another header." + (let lp ((headers headers)) + (match headers + (((k . v) . headers) + (write-header k v port) + (lp headers)) + (() + (values))))) + + + + +;;; +;;; Utilities +;;; + +(define (bad-header sym val) + (throw 'bad-header sym val)) +(define (bad-header-component sym val) + (throw 'bad-header-component sym val)) + +(define (bad-header-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header: ~a\n" (header->string sym) val)) + (_ (default-printer))) + args)) +(define (bad-header-component-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header component: ~a\n" sym val)) + (_ (default-printer))) + args)) +(set-exception-printer! 'bad-header bad-header-printer) +(set-exception-printer! 'bad-header-component bad-header-component-printer) + +(define (parse-opaque-string str) + str) +(define (validate-opaque-string val) + (string? val)) +(define (write-opaque-string val port) + (put-string port val)) + +(define separators-without-slash + (string->char-set "[^][()<>@,;:\\\"?= \t]")) +(define (validate-media-type str) + (let ((idx (string-index str #\/))) + (and idx (= idx (string-rindex str #\/)) + (not (string-index str separators-without-slash))))) +(define (parse-media-type str) + (unless (validate-media-type str) + (bad-header-component 'media-type str)) + (string->symbol str)) + +(define* (skip-whitespace str #:optional (start 0) (end (string-length str))) + (let lp ((i start)) + (if (and (< i end) (char-whitespace? (string-ref str i))) + (lp (1+ i)) + i))) + +(define* (trim-whitespace str #:optional (start 0) (end (string-length str))) + (let lp ((i end)) + (if (and (< start i) (char-whitespace? (string-ref str (1- i)))) + (lp (1- i)) + i))) + +(define* (split-and-trim str #:optional (delim #\,) + (start 0) (end (string-length str))) + (let lp ((i start)) + (if (< i end) + (let* ((idx (string-index str delim i end)) + (tok (string-trim-both str char-set:whitespace i (or idx end)))) + (cons tok (split-and-trim str delim (if idx (1+ idx) end) end))) + '()))) + +(define (list-of-strings? val) + (list-of? val string?)) + +(define (write-list-of-strings val port) + (put-list port val put-string ", ")) + +(define (split-header-names str) + (map string->header (split-and-trim str))) + +(define (list-of-header-names? val) + (list-of? val symbol?)) + +(define (write-header-list val port) + (put-list port val + (lambda (port x) + (put-string port (header->string x))) + ", ")) + +(define (collect-escaped-string from start len escapes) + (let ((to (make-string len))) + (let lp ((start start) (i 0) (escapes escapes)) + (match escapes + (() + (substring-move! from start (+ start (- len i)) to i) + to) + ((e . escapes) + (let ((next-start (+ start (- e i) 2))) + (substring-move! from start (- next-start 2) to i) + (string-set! to e (string-ref from (- next-start 1))) + (lp next-start (1+ e) escapes))))))) + +;; in incremental mode, returns two values: the string, and the index at +;; which the string ended +(define* (parse-qstring str #:optional + (start 0) (end (trim-whitespace str start)) + #:key incremental?) + (unless (and (< start end) (eqv? (string-ref str start) #\")) + (bad-header-component 'qstring str)) + (let lp ((i (1+ start)) (qi 0) (escapes '())) + (if (< i end) + (case (string-ref str i) + ((#\\) + (lp (+ i 2) (1+ qi) (cons qi escapes))) + ((#\") + (let ((out (collect-escaped-string str (1+ start) qi escapes))) + (cond + (incremental? (values out (1+ i))) + ((= (1+ i) end) out) + (else (bad-header-component 'qstring str))))) + (else + (lp (1+ i) (1+ qi) escapes))) + (bad-header-component 'qstring str)))) + +(define (put-list port items put-item delim) + (match items + (() (values)) + ((item . items) + (put-item port item) + (let lp ((items items)) + (match items + (() (values)) + ((item . items) + (put-string port delim) + (put-item port item) + (lp items))))))) + +(define (write-qstring str port) + (put-char port #\") + (if (string-index str #\") + ;; optimize me + (put-list port (string-split str #\") put-string "\\\"") + (put-string port str)) + (put-char port #\")) + +(define* (parse-quality str #:optional (start 0) (end (string-length str))) + (define (char->decimal c) + (let ((i (- (char->integer c) (char->integer #\0)))) + (unless (and (<= 0 i) (< i 10)) + (bad-header-component 'quality str)) + i)) + (cond + ((not (< start end)) + (bad-header-component 'quality str)) + ((eqv? (string-ref str start) #\1) + (unless (or (string= str "1" start end) + (string= str "1." start end) + (string= str "1.0" start end) + (string= str "1.00" start end) + (string= str "1.000" start end)) + (bad-header-component 'quality str)) + 1000) + ((eqv? (string-ref str start) #\0) + (if (or (string= str "0" start end) + (string= str "0." start end)) + 0 + (if (< 2 (- end start) 6) + (let lp ((place 1) (i (+ start 4)) (q 0)) + (if (= i (1+ start)) + (if (eqv? (string-ref str (1+ start)) #\.) + q + (bad-header-component 'quality str)) + (lp (* 10 place) (1- i) + (if (< i end) + (+ q (* place (char->decimal (string-ref str i)))) + q)))) + (bad-header-component 'quality str)))) + ;; Allow the nonstandard .2 instead of 0.2. + ((and (eqv? (string-ref str start) #\.) + (< 1 (- end start) 5)) + (let lp ((place 1) (i (+ start 3)) (q 0)) + (if (= i start) + q + (lp (* 10 place) (1- i) + (if (< i end) + (+ q (* place (char->decimal (string-ref str i)))) + q))))) + (else + (bad-header-component 'quality str)))) + +(define (valid-quality? q) + (and (non-negative-integer? q) (<= q 1000))) + +(define (write-quality q port) + (define (digit->char d) + (integer->char (+ (char->integer #\0) d))) + (put-char port (digit->char (modulo (quotient q 1000) 10))) + (put-char port #\.) + (put-char port (digit->char (modulo (quotient q 100) 10))) + (put-char port (digit->char (modulo (quotient q 10) 10))) + (put-char port (digit->char (modulo q 10)))) + +(define (list-of? val pred) + (match val + (((? pred) ...) #t) + (_ #f))) + +(define* (parse-quality-list str) + (map (lambda (part) + (cond + ((string-rindex part #\;) + => (lambda (idx) + (let ((qpart (string-trim-both part char-set:whitespace (1+ idx)))) + (unless (string-prefix? "q=" qpart) + (bad-header-component 'quality qpart)) + (cons (parse-quality qpart 2) + (string-trim-both part char-set:whitespace 0 idx))))) + (else + (cons 1000 (string-trim-both part char-set:whitespace))))) + (string-split str #\,))) + +(define (validate-quality-list l) + (match l + ((((? valid-quality?) . (? string?)) ...) #t) + (_ #f))) + +(define (write-quality-list l port) + (put-list port l + (lambda (port x) + (let ((q (car x)) + (str (cdr x))) + (put-string port str) + (when (< q 1000) + (put-string port ";q=") + (write-quality q port)))) + ",")) + +(define* (parse-non-negative-integer val #:optional (start 0) + (end (string-length val))) + (define (char->decimal c) + (let ((i (- (char->integer c) (char->integer #\0)))) + (unless (and (<= 0 i) (< i 10)) + (bad-header-component 'non-negative-integer val)) + i)) + (unless (< start end) + (bad-header-component 'non-negative-integer val)) + (let lp ((i start) (out 0)) + (if (< i end) + (lp (1+ i) + (+ (* out 10) (char->decimal (string-ref val i)))) + out))) + +(define (non-negative-integer? code) + (and (number? code) (>= code 0) (exact? code) (integer? code))) + +(define (default-val-parser k val) + val) + +(define (default-val-validator k val) + (or (not val) (string? val))) + +(define (default-val-writer k val port) + (if (or (string-index val #\;) + (string-index val #\,) + (string-index val #\")) + (write-qstring val port) + (put-string port val))) + +(define* (parse-key-value-list str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start)) + (if (not (< i end)) + '() + (let* ((i (skip-whitespace str i end)) + (eq (string-index str #\= i end)) + (comma (string-index str #\, i end)) + (delim (min (or eq end) (or comma end))) + (k (string->symbol + (substring str i (trim-whitespace str i delim))))) + (call-with-values + (lambda () + (if (and eq (or (not comma) (< eq comma))) + (let ((i (skip-whitespace str (1+ eq) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (values (substring str i + (trim-whitespace str i + (or comma end))) + (or comma end)))) + (values #f delim))) + (lambda (v-str next-i) + (let ((v (val-parser k v-str)) + (i (skip-whitespace str next-i end))) + (unless (or (= i end) (eqv? (string-ref str i) #\,)) + (bad-header-component 'key-value-list + (substring str start end))) + (cons (if v (cons k v) k) + (lp (1+ i)))))))))) + +(define* (key-value-list? list #:optional + (valid? default-val-validator)) + (list-of? list + (lambda (elt) + (match elt + (((? symbol? k) . v) (valid? k v)) + ((? symbol? k) (valid? k #f)) + (_ #f))))) + +(define* (write-key-value-list list port #:optional + (val-writer default-val-writer) (delim ", ")) + (put-list + port list + (lambda (port x) + (match x + ((k . #f) + (put-symbol port k)) + ((k . v) + (put-symbol port k) + (put-char port #\=) + (val-writer k v port)) + (k + (put-symbol port k)))) + delim)) + +;; param-component = token [ "=" (token | quoted-string) ] \ +;; *(";" token [ "=" (token | quoted-string) ]) +;; +(define param-delimiters (char-set #\, #\; #\=)) +(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;)) +(define* (parse-param-component str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start) (out '())) + (if (not (< i end)) + (values (reverse! out) end) + (let ((delim (string-index str param-delimiters i))) + (let ((k (string->symbol + (substring str i (trim-whitespace str i (or delim end))))) + (delimc (and delim (string-ref str delim)))) + (case delimc + ((#\=) + (call-with-values + (lambda () + (let ((i (skip-whitespace str (1+ delim) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (let ((delim + (or (string-index str param-value-delimiters + i end) + end))) + (values (substring str i delim) + delim))))) + (lambda (v-str next-i) + (let* ((v (val-parser k v-str)) + (x (if v (cons k v) k)) + (i (skip-whitespace str next-i end))) + (case (and (< i end) (string-ref str i)) + ((#f) + (values (reverse! (cons x out)) end)) + ((#\;) + (lp (skip-whitespace str (1+ i) end) + (cons x out))) + (else ; including #\, + (values (reverse! (cons x out)) i))))))) + ((#\;) + (let ((v (val-parser k #f))) + (lp (skip-whitespace str (1+ delim) end) + (cons (if v (cons k v) k) out)))) + + (else ;; either the end of the string or a #\, + (let ((v (val-parser k #f))) + (values (reverse! (cons (if v (cons k v) k) out)) + (or delim end)))))))))) + +(define* (parse-param-list str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start) (out '())) + (call-with-values + (lambda () (parse-param-component str val-parser i end)) + (lambda (item i) + (if (< i end) + (if (eqv? (string-ref str i) #\,) + (lp (skip-whitespace str (1+ i) end) + (cons item out)) + (bad-header-component 'param-list str)) + (reverse! (cons item out))))))) + +(define* (validate-param-list list #:optional + (valid? default-val-validator)) + (list-of? list + (lambda (elt) + (key-value-list? elt valid?)))) + +(define* (write-param-list list port #:optional + (val-writer default-val-writer)) + (put-list + port list + (lambda (port item) + (write-key-value-list item port val-writer ";")) + ",")) + +(define-syntax string-match? + (lambda (x) + (syntax-case x () + ((_ str pat) (string? (syntax->datum #'pat)) + (let ((p (syntax->datum #'pat))) + #`(let ((s str)) + (and + (= (string-length s) #,(string-length p)) + #,@(let lp ((i 0) (tests '())) + (if (< i (string-length p)) + (let ((c (string-ref p i))) + (lp (1+ i) + (case c + ((#\.) ; Whatever. + tests) + ((#\d) ; Digit. + (cons #`(char-numeric? (string-ref s #,i)) + tests)) + ((#\a) ; Alphabetic. + (cons #`(char-alphabetic? (string-ref s #,i)) + tests)) + (else ; Literal. + (cons #`(eqv? (string-ref s #,i) #,c) + tests))))) + tests))))))))) + +;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" +;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec" + +(define (parse-month str start end) + (define (bad) + (bad-header-component 'month (substring str start end))) + (if (not (= (- end start) 3)) + (bad) + (let ((a (string-ref str (+ start 0))) + (b (string-ref str (+ start 1))) + (c (string-ref str (+ start 2)))) + (case a + ((#\J) + (case b + ((#\a) (case c ((#\n) 1) (else (bad)))) + ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad)))) + (else (bad)))) + ((#\F) + (case b + ((#\e) (case c ((#\b) 2) (else (bad)))) + (else (bad)))) + ((#\M) + (case b + ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad)))) + (else (bad)))) + ((#\A) + (case b + ((#\p) (case c ((#\r) 4) (else (bad)))) + ((#\u) (case c ((#\g) 8) (else (bad)))) + (else (bad)))) + ((#\S) + (case b + ((#\e) (case c ((#\p) 9) (else (bad)))) + (else (bad)))) + ((#\O) + (case b + ((#\c) (case c ((#\t) 10) (else (bad)))) + (else (bad)))) + ((#\N) + (case b + ((#\o) (case c ((#\v) 11) (else (bad)))) + (else (bad)))) + ((#\D) + (case b + ((#\e) (case c ((#\c) 12) (else (bad)))) + (else (bad)))) + (else (bad)))))) + +;; "GMT" | "+" 4DIGIT | "-" 4DIGIT +;; +;; RFC 2616 requires date values to use "GMT", but recommends accepting +;; the others as they are commonly generated by e.g. RFC 822 sources. +(define (parse-zone-offset str start) + (let ((s (substring str start))) + (define (bad) + (bad-header-component 'zone-offset s)) + (cond + ((string=? s "GMT") + 0) + ((string=? s "UTC") + 0) + ((string-match? s ".dddd") + (let ((sign (case (string-ref s 0) + ((#\+) +1) + ((#\-) -1) + (else (bad)))) + (hours (parse-non-negative-integer s 1 3)) + (minutes (parse-non-negative-integer s 3 5))) + (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich + (else (bad))))) + +;; RFC 822, updated by RFC 1123 +;; +;; Sun, 06 Nov 1994 08:49:37 GMT +;; 01234567890123456789012345678 +;; 0 1 2 +(define (parse-rfc-822-date str space zone-offset) + ;; We could verify the day of the week but we don't. + (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 17 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 16 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + ;; The next two clauses match dates that have a space instead of + ;; a leading zero for hours, like " 8:49:37". + ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 18 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 17 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + (else + (bad-header 'date str) ; prevent tail call + #f))) + +;; RFC 850, updated by RFC 1036 +;; Sunday, 06-Nov-94 08:49:37 GMT +;; 0123456789012345678901 +;; 0 1 2 +(define (parse-rfc-850-date str comma space zone-offset) + ;; We could verify the day of the week but we don't. + (let ((tail (substring str (1+ comma) space))) + (unless (string-match? tail " dd-aaa-dd dd:dd:dd") + (bad-header 'date str)) + (let ((date (parse-non-negative-integer tail 1 3)) + (month (parse-month tail 4 7)) + (year (parse-non-negative-integer tail 8 10)) + (hour (parse-non-negative-integer tail 11 13)) + (minute (parse-non-negative-integer tail 14 16)) + (second (parse-non-negative-integer tail 17 19))) + (make-date 0 second minute hour date month + (let* ((now (date-year (current-date))) + (then (+ now year (- (modulo now 100))))) + (cond ((< (+ then 50) now) (+ then 100)) + ((< (+ now 50) then) (- then 100)) + (else then))) + zone-offset)))) + +;; ANSI C's asctime() format +;; Sun Nov 6 08:49:37 1994 +;; 012345678901234567890123 +;; 0 1 2 +(define (parse-asctime-date str) + (unless (string-match? str "aaa aaa .d dd:dd:dd dddd") + (bad-header 'date str)) + (let ((date (parse-non-negative-integer + str + (if (eqv? (string-ref str 8) #\space) 9 8) + 10)) + (month (parse-month str 4 7)) + (year (parse-non-negative-integer str 20 24)) + (hour (parse-non-negative-integer str 11 13)) + (minute (parse-non-negative-integer str 14 16)) + (second (parse-non-negative-integer str 17 19))) + (make-date 0 second minute hour date month year 0))) + +;; Convert all date values to GMT time zone, as per RFC 2616 appendix C. +(define (normalize-date date) + (if (zero? (date-zone-offset date)) + date + (time-utc->date (date->time-utc date) 0))) + +(define (parse-date str) + (let* ((space (string-rindex str #\space)) + (zone-offset (and space (false-if-exception + (parse-zone-offset str (1+ space)))))) + (normalize-date + (if zone-offset + (let ((comma (string-index str #\,))) + (cond ((not comma) (bad-header 'date str)) + ((= comma 3) (parse-rfc-822-date str space zone-offset)) + (else (parse-rfc-850-date str comma space zone-offset)))) + (parse-asctime-date str))))) + +(define (write-date date port) + (define (put-digits port n digits) + (define zero (char->integer #\0)) + (let lp ((tens (expt 10 (1- digits)))) + (when (> tens 0) + (put-char port + (integer->char (+ zero (modulo (truncate/ n tens) 10)))) + (lp (floor/ tens 10))))) + (let ((date (if (zero? (date-zone-offset date)) + date + (time-tai->date (date->time-tai date) 0)))) + (put-string port + (case (date-week-day date) + ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ") + ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ") + ((6) "Sat, ") (else (error "bad date" date)))) + (put-digits port (date-day date) 2) + (put-string port + (case (date-month date) + ((1) " Jan ") ((2) " Feb ") ((3) " Mar ") + ((4) " Apr ") ((5) " May ") ((6) " Jun ") + ((7) " Jul ") ((8) " Aug ") ((9) " Sep ") + ((10) " Oct ") ((11) " Nov ") ((12) " Dec ") + (else (error "bad date" date)))) + (put-digits port (date-year date) 4) + (put-char port #\space) + (put-digits port (date-hour date) 2) + (put-char port #\:) + (put-digits port (date-minute date) 2) + (put-char port #\:) + (put-digits port (date-second date) 2) + (put-string port " GMT"))) + +;; Following https://tools.ietf.org/html/rfc7232#section-2.3, an entity +;; tag should really be a qstring. However there are a number of +;; servers that emit etags as unquoted strings. Assume that if the +;; value doesn't start with a quote, it's an unquoted strong etag. +(define* (parse-entity-tag val #:optional (start 0) (end (string-length val)) + #:key sloppy-delimiters) + (define (parse-proper-etag-at start strong?) + (cond + (sloppy-delimiters + (call-with-values (lambda () + (parse-qstring val start end #:incremental? #t)) + (lambda (tag next) + (values (cons tag strong?) next)))) + (else + (values (cons (parse-qstring val start end) strong?) end)))) + (cond + ((string-prefix? "W/" val 0 2 start end) + (parse-proper-etag-at (+ start 2) #f)) + ((string-prefix? "\"" val 0 1 start end) + (parse-proper-etag-at start #t)) + (else + (let ((delim (or (and sloppy-delimiters + (string-index val sloppy-delimiters start end)) + end))) + (values (cons (substring val start delim) #t) delim))))) + +(define (entity-tag? val) + (match val + (((? string?) . _) #t) + (_ #f))) + +(define (put-entity-tag port val) + (match val + ((tag . strong?) + (unless strong? (put-string port "W/")) + (write-qstring tag port)))) + +(define* (parse-entity-tag-list val #:optional + (start 0) (end (string-length val))) + (call-with-values (lambda () + (parse-entity-tag val start end #:sloppy-delimiters #\,)) + (lambda (etag next) + (cons etag + (let ((next (skip-whitespace val next end))) + (if (< next end) + (if (eqv? (string-ref val next) #\,) + (parse-entity-tag-list + val + (skip-whitespace val (1+ next) end) + end) + (bad-header-component 'entity-tag-list val)) + '())))))) + +(define (entity-tag-list? val) + (list-of? val entity-tag?)) + +(define (put-entity-tag-list port val) + (put-list port val put-entity-tag ", ")) + +;; credentials = auth-scheme #auth-param +;; auth-scheme = token +;; auth-param = token "=" ( token | quoted-string ) +;; +;; That's what the spec says. In reality the Basic scheme doesn't have +;; k-v pairs, just one auth token, so we give that token as a string. +;; +(define* (parse-credentials str #:optional (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let* ((start (skip-whitespace str start end)) + (delim (or (string-index str char-set:whitespace start end) end))) + (when (= start end) + (bad-header-component 'authorization str)) + (let ((scheme (string->symbol + (string-downcase (substring str start (or delim end)))))) + (case scheme + ((basic) + (let* ((start (skip-whitespace str delim end))) + (unless (< start end) + (bad-header-component 'credentials str)) + (cons scheme (substring str start end)))) + (else + (cons scheme (parse-key-value-list str default-val-parser delim end))))))) + +(define (validate-credentials val) + (match val + (('basic . (? string?)) #t) + (((? symbol?) . (? key-value-list?)) #t) + (_ #f))) + +;; While according to RFC 7617 Schemes are case-insensitive: +;; +;; 'Note that both scheme and parameter names are matched +;; case-insensitive' +;; +;; some software (*) incorrectly assumes title case for scheme +;; names, so use the more titlecase. +;; +;; (*): See, e.g., +;; https://community.spotify.com/t5/Spotify-for-Developers/API-Authorization-header-doesn-t-follow-HTTP-spec/m-p/5397381#M4917 +(define (write-credentials val port) + (match val + (('basic . cred) + (put-string port "Basic ") + (put-string port cred)) + ((scheme . params) + (put-string port (string-titlecase (symbol->string scheme))) + (put-char port #\space) + (write-key-value-list params port)))) + +;; challenges = 1#challenge +;; challenge = auth-scheme 1*SP 1#auth-param +;; +;; A pain to parse, as both challenges and auth params are delimited by +;; commas, and qstrings can contain anything. We rely on auth params +;; necessarily having "=" in them. +;; +(define* (parse-challenge str #:optional + (start 0) (end (string-length str))) + (let* ((start (skip-whitespace str start end)) + (sp (string-index str #\space start end)) + (scheme (if sp + (string->symbol (string-downcase (substring str start sp))) + (bad-header-component 'challenge str)))) + (let lp ((i sp) (out (list scheme))) + (if (not (< i end)) + (values (reverse! out) end) + (let* ((i (skip-whitespace str i end)) + (eq (string-index str #\= i end)) + (comma (string-index str #\, i end)) + (delim (min (or eq end) (or comma end))) + (token-end (trim-whitespace str i delim))) + (if (string-index str #\space i token-end) + (values (reverse! out) i) + (let ((k (string->symbol (substring str i token-end)))) + (call-with-values + (lambda () + (if (and eq (or (not comma) (< eq comma))) + (let ((i (skip-whitespace str (1+ eq) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (values (substring + str i + (trim-whitespace str i + (or comma end))) + (or comma end)))) + (values #f delim))) + (lambda (v next-i) + (let ((i (skip-whitespace str next-i end))) + (unless (or (= i end) (eqv? (string-ref str i) #\,)) + (bad-header-component 'challenge + (substring str start end))) + (lp (1+ i) (cons (if v (cons k v) k) out)))))))))))) + +(define* (parse-challenges str #:optional (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start)) + (let ((i (skip-whitespace str i end))) + (if (< i end) + (call-with-values (lambda () (parse-challenge str i end)) + (lambda (challenge i) + (cons challenge (lp i)))) + '())))) + +(define (validate-challenges val) + (match val + ((((? symbol?) . (? key-value-list?)) ...) #t) + (_ #f))) + +(define (put-challenge port val) + (match val + ((scheme . params) + (put-symbol port scheme) + (put-char port #\space) + (write-key-value-list params port)))) + +(define (write-challenges val port) + (put-list port val put-challenge ", ")) + + + + +;;; +;;; Request-Line and Response-Line +;;; + +;; Hmm. +(define (bad-request message . args) + (throw 'bad-request message args)) +(define (bad-response message . args) + (throw 'bad-response message args)) + +(define *known-versions* '()) + +(define* (parse-http-version str #:optional (start 0) (end (string-length str))) + "Parse an HTTP version from STR, returning it as a major–minor +pair. For example, ‘HTTP/1.1’ parses as the pair of integers, +‘(1 . 1)’." + (let lp ((known *known-versions*)) + (match known + (((version-str . version-val) . known) + (if (string= str version-str start end) + version-val + (lp known))) + (() + (let ((dot-idx (string-index str #\. start end))) + (unless (and (string-prefix? "HTTP/" str 0 5 start end) + dot-idx + (= dot-idx (string-rindex str #\. start end))) + + (bad-header-component 'http-version (substring str start end))) + (cons (parse-non-negative-integer str (+ start 5) dot-idx) + (parse-non-negative-integer str (1+ dot-idx) end))))))) + +(define (write-http-version val port) + "Write the given major-minor version pair to PORT." + (put-string port "HTTP/") + (put-non-negative-integer port (car val)) + (put-char port #\.) + (put-non-negative-integer port (cdr val))) + +(for-each + (lambda (v) + (set! *known-versions* + (acons v (parse-http-version v 0 (string-length v)) + *known-versions*))) + '("HTTP/1.0" "HTTP/1.1")) + + +(define *declared-methods* '()) + +(define (declare-method! str symb) + (set! *declared-methods* (acons str symb *declared-methods*))) + +;; Request-URI = "*" | absoluteURI | abs_path | authority +;; +;; The `authority' form is only permissible for the CONNECT method, so +;; because we don't expect people to implement CONNECT, we save +;; ourselves the trouble of that case, and disallow the CONNECT method. +;; +(define* (parse-http-method str #:optional (start 0) (end (string-length str))) + "Parse an HTTP method from STR. The result is an upper-case +symbol, like ‘GET’." + (cdr + (or (find (lambda (pair) (string= str (car pair) start end)) + *declared-methods*) + (bad-request "Invalid method: ~a" (substring str start end))))) + +(declare-method! "GET" 'GET) +(declare-method! "HEAD" 'HEAD) +(declare-method! "POST" 'POST) +(declare-method! "PUT" 'PUT) +(declare-method! "DELETE" 'DELETE) +(declare-method! "OPTIONS" 'OPTIONS) +(declare-method! "TRACE" 'TRACE) +(declare-method! "CONNECT" 'CONNECT) +(declare-method! "PATCH" 'PATCH) + +(define* (parse-request-uri str #:optional (start 0) (end (string-length str))) + "Parse a URI from an HTTP request line. Note that URIs in requests do +not have to have a scheme or host name. The result is a URI-reference +object." + (cond + ((= start end) + (bad-request "Missing Request-URI")) + ((string= str "*" start end) + #f) + ((eqv? (string-ref str start) #\/) + (let* ((q (string-index str #\? start end)) + (f (string-index str #\# start end)) + (q (and q (or (not f) (< q f)) q))) + (build-uri-reference + #:path (substring str start (or q f end)) + #:query (and q (substring str (1+ q) (or f end))) + #:fragment (and f (substring str (1+ f) end))))) + (else + (or (string->uri (substring str start end)) + (bad-request "Invalid URI: ~a" (substring str start end)))))) + +(define (read-request-line port) + "Read the first line of an HTTP request from PORT, returning +three values: the method, the URI, and the version." + (let* ((line (read-header-line port)) + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (string-rindex line char-set:whitespace))) + (unless (and d0 d1 (< d0 d1)) + (bad-request "Bad Request-Line: ~s" line)) + (values (parse-http-method line 0 d0) + (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1) + (parse-http-version line (1+ d1) (string-length line))))) + +(define (write-uri uri port) + (put-string port (uri->string uri #:include-fragment? #f))) + +(define (write-request-line method uri version port) + "Write the first line of an HTTP request to PORT." + (put-symbol port method) + (put-char port #\space) + (when (http-proxy-port? port) + (let ((scheme (uri-scheme uri)) + (host (uri-host uri)) + (host-port (uri-port uri))) + (when (and scheme host) + (put-symbol port scheme) + (put-string port "://") + (cond + ((string-index host #\:) + (put-char port #\[) + (put-string port host) + (put-char port #\])) + (else + (put-string port host))) + (unless ((@@ (web uri) default-port?) scheme host-port) + (put-char port #\:) + (put-non-negative-integer port host-port))))) + (let ((path (uri-path uri)) + (query (uri-query uri))) + (if (string-null? path) + (put-string port "/") + (put-string port path)) + (when query + (put-string port "?") + (put-string port query))) + (put-char port #\space) + (write-http-version version port) + (put-string port "\r\n")) + +(define (read-response-line port) + "Read the first line of an HTTP response from PORT, returning three +values: the HTTP version, the response code, and the (possibly empty) +\"reason phrase\"." + (let* ((line (read-header-line port)) + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (and d0 (string-index line char-set:whitespace + (skip-whitespace line d0))))) + (unless (and d0 d1) + (bad-response "Bad Response-Line: ~s" line)) + (values (parse-http-version line 0 d0) + (parse-non-negative-integer line (skip-whitespace line d0 d1) + d1) + (string-trim-both line char-set:whitespace d1)))) + +(define (write-response-line version code reason-phrase port) + "Write the first line of an HTTP response to PORT." + (write-http-version version port) + (put-char port #\space) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port reason-phrase) + (put-string port "\r\n")) + + + + +;;; +;;; Helpers for declaring headers +;;; + +;; emacs: (put 'declare-header! 'scheme-indent-function 1) +;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1) +(define (declare-opaque-header! name) + "Declares a given header as \"opaque\", meaning that its value is not +treated specially, and is just returned as a plain string." + (declare-header! name + parse-opaque-string validate-opaque-string write-opaque-string)) + +;; emacs: (put 'declare-date-header! 'scheme-indent-function 1) +(define (declare-date-header! name) + (declare-header! name + parse-date date? write-date)) + +;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1) +(define (declare-string-list-header! name) + (declare-header! name + split-and-trim list-of-strings? write-list-of-strings)) + +;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1) +(define (declare-symbol-list-header! name) + (declare-header! name + (lambda (str) + (map string->symbol (split-and-trim str))) + (lambda (v) + (list-of? v symbol?)) + (lambda (v port) + (put-list port v put-symbol ", ")))) + +;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1) +(define (declare-header-list-header! name) + (declare-header! name + split-header-names list-of-header-names? write-header-list)) + +;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1) +(define (declare-integer-header! name) + (declare-header! name + parse-non-negative-integer non-negative-integer? + (lambda (val port) (put-non-negative-integer port val)))) + +;; emacs: (put 'declare-uri-reference-header! 'scheme-indent-function 1) +(define (declare-uri-reference-header! name) + (declare-header! name + (lambda (str) + (or (string->uri-reference str) + (bad-header-component 'uri-reference str))) + uri-reference? + write-uri)) + +;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1) +(define (declare-quality-list-header! name) + (declare-header! name + parse-quality-list validate-quality-list write-quality-list)) + +;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1) +(define* (declare-param-list-header! name #:optional + (val-parser default-val-parser) + (val-validator default-val-validator) + (val-writer default-val-writer)) + (declare-header! name + (lambda (str) (parse-param-list str val-parser)) + (lambda (val) (validate-param-list val val-validator)) + (lambda (val port) (write-param-list val port val-writer)))) + +;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1) +(define* (declare-key-value-list-header! name #:optional + (val-parser default-val-parser) + (val-validator default-val-validator) + (val-writer default-val-writer)) + (declare-header! name + (lambda (str) (parse-key-value-list str val-parser)) + (lambda (val) (key-value-list? val val-validator)) + (lambda (val port) (write-key-value-list val port val-writer)))) + +;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1) +(define (declare-entity-tag-list-header! name) + (declare-header! name + (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str))) + (lambda (val) (or (eq? val '*) (entity-tag-list? val))) + (lambda (val port) + (if (eq? val '*) + (put-string port "*") + (put-entity-tag-list port val))))) + +;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1) +(define (declare-credentials-header! name) + (declare-header! name + parse-credentials validate-credentials write-credentials)) + +;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1) +(define (declare-challenge-list-header! name) + (declare-header! name + parse-challenges validate-challenges write-challenges)) + + + + +;;; +;;; General headers +;;; + +;; Cache-Control = 1#(cache-directive) +;; cache-directive = cache-request-directive | cache-response-directive +;; cache-request-directive = +;; "no-cache" ; Section 14.9.1 +;; | "no-store" ; Section 14.9.2 +;; | "max-age" "=" delta-seconds ; Section 14.9.3, 14.9.4 +;; | "max-stale" [ "=" delta-seconds ] ; Section 14.9.3 +;; | "min-fresh" "=" delta-seconds ; Section 14.9.3 +;; | "no-transform" ; Section 14.9.5 +;; | "only-if-cached" ; Section 14.9.4 +;; | cache-extension ; Section 14.9.6 +;; cache-response-directive = +;; "public" ; Section 14.9.1 +;; | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1 +;; | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1 +;; | "no-store" ; Section 14.9.2 +;; | "no-transform" ; Section 14.9.5 +;; | "must-revalidate" ; Section 14.9.4 +;; | "proxy-revalidate" ; Section 14.9.4 +;; | "max-age" "=" delta-seconds ; Section 14.9.3 +;; | "s-maxage" "=" delta-seconds ; Section 14.9.3 +;; | cache-extension ; Section 14.9.6 +;; cache-extension = token [ "=" ( token | quoted-string ) ] +;; +(declare-key-value-list-header! "Cache-Control" + (lambda (k v-str) + (case k + ((max-age min-fresh s-maxage) + (parse-non-negative-integer v-str)) + ((max-stale) + (and v-str (parse-non-negative-integer v-str))) + ((private no-cache) + (and v-str (split-header-names v-str))) + (else v-str))) + (lambda (k v) + (case k + ((max-age min-fresh s-maxage) + (non-negative-integer? v)) + ((max-stale) + (or (not v) (non-negative-integer? v))) + ((private no-cache) + (or (not v) (list-of-header-names? v))) + ((no-store no-transform only-if-cache must-revalidate proxy-revalidate) + (not v)) + (else + (or (not v) (string? v))))) + (lambda (k v port) + (cond + ((string? v) (default-val-writer k v port)) + ((pair? v) + (put-char port #\") + (write-header-list v port) + (put-char port #\")) + ((integer? v) + (put-non-negative-integer port v)) + (else + (bad-header-component 'cache-control v))))) + +;; Connection = "Connection" ":" 1#(connection-token) +;; connection-token = token +;; e.g. +;; Connection: close, Foo-Header +;; +(declare-header! "Connection" + split-header-names + list-of-header-names? + (lambda (val port) + (put-list port val + (lambda (port x) + (put-string port + (if (eq? x 'close) + "close" + (header->string x)))) + ", "))) + +;; Date = "Date" ":" HTTP-date +;; e.g. +;; Date: Tue, 15 Nov 1994 08:12:31 GMT +;; +(declare-date-header! "Date") + +;; Pragma = "Pragma" ":" 1#pragma-directive +;; pragma-directive = "no-cache" | extension-pragma +;; extension-pragma = token [ "=" ( token | quoted-string ) ] +;; +(declare-key-value-list-header! "Pragma") + +;; Trailer = "Trailer" ":" 1#field-name +;; +(declare-header-list-header! "Trailer") + +;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding +;; +(declare-param-list-header! "Transfer-Encoding") + +;; Upgrade = "Upgrade" ":" 1#product +;; +(declare-string-list-header! "Upgrade") + +;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] ) +;; received-protocol = [ protocol-name "/" ] protocol-version +;; protocol-name = token +;; protocol-version = token +;; received-by = ( host [ ":" port ] ) | pseudonym +;; pseudonym = token +;; +(declare-header! "Via" + split-and-trim + list-of-strings? + write-list-of-strings + #:multiple? #t) + +;; Warning = "Warning" ":" 1#warning-value +;; +;; warning-value = warn-code SP warn-agent SP warn-text +;; [SP warn-date] +;; +;; warn-code = 3DIGIT +;; warn-agent = ( host [ ":" port ] ) | pseudonym +;; ; the name or pseudonym of the server adding +;; ; the Warning header, for use in debugging +;; warn-text = quoted-string +;; warn-date = <"> HTTP-date <"> +(declare-header! "Warning" + (lambda (str) + (let ((len (string-length str))) + (let lp ((i (skip-whitespace str 0))) + (let* ((idx1 (string-index str #\space i)) + (idx2 (string-index str #\space (1+ idx1)))) + (when (and idx1 idx2) + (let ((code (parse-non-negative-integer str i idx1)) + (agent (substring str (1+ idx1) idx2))) + (call-with-values + (lambda () (parse-qstring str (1+ idx2) #:incremental? #t)) + (lambda (text i) + (call-with-values + (lambda () + (let ((c (and (< i len) (string-ref str i)))) + (case c + ((#\space) + ;; we have a date. + (call-with-values + (lambda () (parse-qstring str (1+ i) + #:incremental? #t)) + (lambda (date i) + (values text (parse-date date) i)))) + (else + (values text #f i))))) + (lambda (text date i) + (let ((w (list code agent text date)) + (c (and (< i len) (string-ref str i)))) + (case c + ((#f) (list w)) + ((#\,) (cons w (lp (skip-whitespace str (1+ i))))) + (else (bad-header 'warning str)))))))))))))) + (lambda (val) + (list-of? val + (lambda (elt) + (match elt + ((code host text date) + (and (non-negative-integer? code) (< code 1000) + (string? host) + (string? text) + (or (not date) (date? date)))) + (_ #f))))) + (lambda (val port) + (put-list + port val + (lambda (port w) + (match w + ((code host text date) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port host) + (put-char port #\space) + (write-qstring text port) + (when date + (put-char port #\space) + (put-char port #\") + (write-date date port) + (put-char port #\"))))) + ", ")) + #:multiple? #t) + + + + +;;; +;;; Entity headers +;;; + +;; Allow = #Method +;; +(declare-symbol-list-header! "Allow") + +;; Content-Disposition = disposition-type *( ";" disposition-parm ) +;; disposition-type = "attachment" | disp-extension-token +;; disposition-parm = filename-parm | disp-extension-parm +;; filename-parm = "filename" "=" quoted-string +;; disp-extension-token = token +;; disp-extension-parm = token "=" ( token | quoted-string ) +;; +(declare-header! "Content-Disposition" + (lambda (str) + ;; Lazily reuse the param list parser. + (match (parse-param-list str default-val-parser) + ((disposition) disposition) + (_ (bad-header-component 'content-disposition str)))) + (lambda (val) + (match val + (((? symbol?) ((? symbol?) . (? string?)) ...) #t) + (_ #f))) + (lambda (val port) + (write-param-list (list val) port))) + +;; Content-Encoding = 1#content-coding +;; +(declare-symbol-list-header! "Content-Encoding") + +;; Content-Language = 1#language-tag +;; +(declare-string-list-header! "Content-Language") + +;; Content-Length = 1*DIGIT +;; +(declare-integer-header! "Content-Length") + +;; Content-Location = URI-reference +;; +(declare-uri-reference-header! "Content-Location") + +;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864> +;; +(declare-opaque-header! "Content-MD5") + +;; Content-Range = content-range-spec +;; content-range-spec = byte-content-range-spec +;; byte-content-range-spec = bytes-unit SP +;; byte-range-resp-spec "/" +;; ( instance-length | "*" ) +;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos) +;; | "*" +;; instance-length = 1*DIGIT +;; +(declare-header! "Content-Range" + (lambda (str) + (let ((dash (string-index str #\-)) + (slash (string-index str #\/))) + (unless (and (string-prefix? "bytes " str) slash) + (bad-header 'content-range str)) + (list 'bytes + (cond + (dash + (cons + (parse-non-negative-integer str 6 dash) + (parse-non-negative-integer str (1+ dash) slash))) + ((string= str "*" 6 slash) + '*) + (else + (bad-header 'content-range str))) + (if (string= str "*" (1+ slash)) + '* + (parse-non-negative-integer str (1+ slash)))))) + (lambda (val) + (match val + (((? symbol?) + (or '* ((? non-negative-integer?) . (? non-negative-integer?))) + (or '* (? non-negative-integer?))) + #t) + (_ #f))) + (lambda (val port) + (match val + ((unit range instance-length) + (put-symbol port unit) + (put-char port #\space) + (match range + ('* + (put-char port #\*)) + ((start . end) + (put-non-negative-integer port start) + (put-char port #\-) + (put-non-negative-integer port end))) + (put-char port #\/) + (match instance-length + ('* (put-char port #\*)) + (len (put-non-negative-integer port len))))))) + +;; Content-Type = media-type +;; +(declare-header! "Content-Type" + (lambda (str) + (let ((parts (string-split str #\;))) + (cons (parse-media-type (car parts)) + (map (lambda (x) + (let ((eq (string-index x #\=))) + (unless (and eq (= eq (string-rindex x #\=))) + (bad-header 'content-type str)) + (cons + (string->symbol + (string-trim x char-set:whitespace 0 eq)) + (string-trim-right x char-set:whitespace (1+ eq))))) + (cdr parts))))) + (lambda (val) + (match val + (((? symbol?) ((? symbol?) . (? string?)) ...) #t) + (_ #f))) + (lambda (val port) + (match val + ((type . args) + (put-symbol port type) + (match args + (() (values)) + (args + (put-string port ";") + (put-list + port args + (lambda (port pair) + (match pair + ((k . v) + (put-symbol port k) + (put-char port #\=) + (put-string port v)))) + ";"))))))) + +;; Expires = HTTP-date +;; +(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT")) + +(declare-header! "Expires" + (lambda (str) + (if (member str '("0" "-1")) + *date-in-the-past* + (parse-date str))) + date? + write-date) + +;; Last-Modified = HTTP-date +;; +(declare-date-header! "Last-Modified") + + + + +;;; +;;; Request headers +;;; + +;; Accept = #( media-range [ accept-params ] ) +;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) ) +;; *( ";" parameter ) +;; accept-params = ";" "q" "=" qvalue *( accept-extension ) +;; accept-extension = ";" token [ "=" ( token | quoted-string ) ] +;; +(declare-param-list-header! "Accept" + ;; -> (type/subtype (sym-prop . str-val) ...) ...) + ;; + ;; with the exception of prop `q', in which case the val will be a + ;; valid quality value + ;; + (lambda (k v) + (if (eq? k 'q) + (parse-quality v) + v)) + (lambda (k v) + (if (eq? k 'q) + (valid-quality? v) + (or (not v) (string? v)))) + (lambda (k v port) + (if (eq? k 'q) + (write-quality v port) + (default-val-writer k v port)))) + +;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] ) +;; +(declare-quality-list-header! "Accept-Charset") + +;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] ) +;; codings = ( content-coding | "*" ) +;; +(declare-quality-list-header! "Accept-Encoding") + +;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] ) +;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" ) +;; +(declare-quality-list-header! "Accept-Language") + +;; Authorization = credentials +;; credentials = auth-scheme #auth-param +;; auth-scheme = token +;; auth-param = token "=" ( token | quoted-string ) +;; +(declare-credentials-header! "Authorization") + +;; Expect = 1#expectation +;; expectation = "100-continue" | expectation-extension +;; expectation-extension = token [ "=" ( token | quoted-string ) +;; *expect-params ] +;; expect-params = ";" token [ "=" ( token | quoted-string ) ] +;; +(declare-param-list-header! "Expect") + +;; From = mailbox +;; +;; Should be an email address; we just pass on the string as-is. +;; +(declare-opaque-header! "From") + +;; Host = host [ ":" port ] +;; +(declare-header! "Host" + (lambda (str) + (let* ((rbracket (string-index str #\])) + (colon (string-index str #\: (or rbracket 0))) + (host (cond + (rbracket + (unless (eqv? (string-ref str 0) #\[) + (bad-header 'host str)) + (substring str 1 rbracket)) + (colon + (substring str 0 colon)) + (else + str))) + (port (and colon + (parse-non-negative-integer str (1+ colon))))) + (cons host port))) + (lambda (val) + (match val + (((? string?) . (or #f (? non-negative-integer?))) #t) + (_ #f))) + (lambda (val port) + (match val + ((host-name . host-port) + (cond + ((string-index host-name #\:) + (put-char port #\[) + (put-string port host-name) + (put-char port #\])) + (else + (put-string port host-name))) + (when host-port + (put-char port #\:) + (put-non-negative-integer port host-port)))))) + +;; If-Match = ( "*" | 1#entity-tag ) +;; +(declare-entity-tag-list-header! "If-Match") + +;; If-Modified-Since = HTTP-date +;; +(declare-date-header! "If-Modified-Since") + +;; If-None-Match = ( "*" | 1#entity-tag ) +;; +(declare-entity-tag-list-header! "If-None-Match") + +;; If-Range = ( entity-tag | HTTP-date ) +;; +(declare-header! "If-Range" + (lambda (str) + (if (or (string-prefix? "\"" str) + (string-prefix? "W/" str)) + (parse-entity-tag str) + (parse-date str))) + (lambda (val) + (or (date? val) (entity-tag? val))) + (lambda (val port) + (if (date? val) + (write-date val port) + (put-entity-tag port val)))) + +;; If-Unmodified-Since = HTTP-date +;; +(declare-date-header! "If-Unmodified-Since") + +;; Max-Forwards = 1*DIGIT +;; +(declare-integer-header! "Max-Forwards") + +;; Proxy-Authorization = credentials +;; +(declare-credentials-header! "Proxy-Authorization") + +;; Range = "Range" ":" ranges-specifier +;; ranges-specifier = byte-ranges-specifier +;; byte-ranges-specifier = bytes-unit "=" byte-range-set +;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec ) +;; byte-range-spec = first-byte-pos "-" [last-byte-pos] +;; first-byte-pos = 1*DIGIT +;; last-byte-pos = 1*DIGIT +;; suffix-byte-range-spec = "-" suffix-length +;; suffix-length = 1*DIGIT +;; +(declare-header! "Range" + (lambda (str) + (unless (string-prefix? "bytes=" str) + (bad-header 'range str)) + (cons + 'bytes + (map (lambda (x) + (let ((dash (string-index x #\-))) + (cond + ((not dash) + (bad-header 'range str)) + ((zero? dash) + (cons #f (parse-non-negative-integer x 1))) + ((= dash (1- (string-length x))) + (cons (parse-non-negative-integer x 0 dash) #f)) + (else + (cons (parse-non-negative-integer x 0 dash) + (parse-non-negative-integer x (1+ dash))))))) + (string-split (substring str 6) #\,)))) + (lambda (val) + (match val + (((? symbol?) + (or (#f . (? non-negative-integer?)) + ((? non-negative-integer?) . (? non-negative-integer?)) + ((? non-negative-integer?) . #f)) + ...) #t) + (_ #f))) + (lambda (val port) + (match val + ((unit . ranges) + (put-symbol port unit) + (put-char port #\=) + (put-list + port ranges + (lambda (port range) + (match range + ((start . end) + (when start (put-non-negative-integer port start)) + (put-char port #\-) + (when end (put-non-negative-integer port end))))) + ","))))) + +;; Referer = URI-reference +;; +(declare-uri-reference-header! "Referer") + +;; TE = #( t-codings ) +;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) +;; +(declare-param-list-header! "TE") + +;; User-Agent = 1*( product | comment ) +;; +(declare-opaque-header! "User-Agent") + + + + +;;; +;;; Reponse headers +;;; + +;; Accept-Ranges = acceptable-ranges +;; acceptable-ranges = 1#range-unit | "none" +;; +(declare-symbol-list-header! "Accept-Ranges") + +;; Age = age-value +;; age-value = delta-seconds +;; +(declare-integer-header! "Age") + +;; ETag = entity-tag +;; +(declare-header! "ETag" + parse-entity-tag + entity-tag? + (lambda (val port) + (put-entity-tag port val))) + +;; Location = URI-reference +;; +;; In RFC 2616, Location was specified as being an absolute URI. This +;; was changed in RFC 7231 to permit URI references generally, which +;; matches web reality. +;; +(declare-uri-reference-header! "Location") + +;; Proxy-Authenticate = 1#challenge +;; +(declare-challenge-list-header! "Proxy-Authenticate") + +;; Retry-After = ( HTTP-date | delta-seconds ) +;; +(declare-header! "Retry-After" + (lambda (str) + (if (and (not (string-null? str)) + (char-numeric? (string-ref str 0))) + (parse-non-negative-integer str) + (parse-date str))) + (lambda (val) + (or (date? val) (non-negative-integer? val))) + (lambda (val port) + (if (date? val) + (write-date val port) + (put-non-negative-integer port val)))) + +;; Server = 1*( product | comment ) +;; +(declare-opaque-header! "Server") + +;; Vary = ( "*" | 1#field-name ) +;; +(declare-header! "Vary" + (lambda (str) + (if (equal? str "*") + '* + (split-header-names str))) + (lambda (val) + (or (eq? val '*) (list-of-header-names? val))) + (lambda (val port) + (if (eq? val '*) + (put-string port "*") + (write-header-list val port)))) + +;; WWW-Authenticate = 1#challenge +;; +(declare-challenge-list-header! "WWW-Authenticate") + + +;; Chunked Responses +(define &chunked-input-ended-prematurely + (make-exception-type '&chunked-input-error-prematurely + &external-error + '())) + +(define make-chunked-input-ended-prematurely-error + (record-constructor &chunked-input-ended-prematurely)) + +(define chunked-input-ended-prematurely-error? + (record-predicate &chunked-input-ended-prematurely)) + +(define (read-chunk-header port) + "Read a chunk header from PORT and return the size in bytes of the +upcoming chunk." + (match (read-line port) + ((? eof-object?) + ;; Connection closed prematurely: there's nothing left to read. + 0) + (str + (let ((extension-start (string-index str + (lambda (c) + (or (char=? c #\;) + (char=? c #\return)))))) + (string->number (if extension-start ; unnecessary? + (substring str 0 extension-start) + str) + 16))))) + +(define* (make-chunked-input-port port #:key (keep-alive? #f)) + "Returns a new port which translates HTTP chunked transfer encoded +data from PORT into a non-encoded format. Returns eof when it has +read the final chunk from PORT. This does not necessarily mean +that there is no more data on PORT. When the returned port is +closed it will also close PORT, unless the KEEP-ALIVE? is true." + (define (close) + (unless keep-alive? + (close-port port))) + + (define chunk-size 0) ;size of the current chunk + (define remaining 0) ;number of bytes left from the current chunk + (define finished? #f) ;did we get all the chunks? + + (define (read! bv idx to-read) + (define (loop to-read num-read) + (cond ((or finished? (zero? to-read)) + num-read) + ((zero? remaining) ;get a new chunk + (let ((size (read-chunk-header port))) + (set! chunk-size size) + (set! remaining size) + (cond + ((zero? size) + (set! finished? #t) + (get-bytevector-n port 2) ; \r\n follows the last chunk + num-read) + (else + (loop to-read num-read))))) + (else ;read from the current chunk + (let* ((ask-for (min to-read remaining)) + (read (get-bytevector-n! port bv (+ idx num-read) + ask-for))) + (cond + ((eof-object? read) ;premature termination + (raise-exception + (make-chunked-input-ended-prematurely-error))) + (else + (let ((left (- remaining read))) + (set! remaining left) + (when (zero? left) + ;; We're done with this chunk; read CR and LF. + (get-u8 port) (get-u8 port)) + (loop (- to-read read) + (+ num-read read))))))))) + (loop to-read 0)) + + (make-custom-binary-input-port "chunked input port" read! #f #f close)) + +(define* (make-chunked-output-port port #:key (keep-alive? #f) + (buffering 1200)) + "Returns a new port which translates non-encoded data into a HTTP +chunked transfer encoded data and writes this to PORT. Data written to +this port is buffered until the port is flushed, at which point it is +all sent as one chunk. The port will otherwise be flushed every +BUFFERING bytes, which defaults to 1200. Take care to close the port +when done, as it will output the remaining data, and encode the final +zero chunk. When the port is closed it will also close PORT, unless +KEEP-ALIVE? is true." + (define (q-for-each f q) + (while (not (q-empty? q)) + (f (deq! q)))) + (define queue (make-q)) + (define (%put-char c) + (enq! queue c)) + (define (%put-string s) + (string-for-each (lambda (c) (enq! queue c)) + s)) + (define (flush) + ;; It is important that we do _not_ write a chunk if the queue is + ;; empty, since it will be treated as the final chunk. + (unless (q-empty? queue) + (let ((len (q-length queue))) + (put-string port (number->string len 16)) + (put-string port "\r\n") + (q-for-each (lambda (elem) (put-char port elem)) + queue) + (put-string port "\r\n")))) + (define (close) + (flush) + (put-string port "0\r\n\r\n") + (force-output port) + (unless keep-alive? + (close-port port))) + (let ((ret (make-soft-port (vector %put-char %put-string flush #f close) "w"))) + (setvbuf ret 'block buffering) + ret)) + +(define %http-proxy-port? (make-object-property)) +(define (http-proxy-port? port) (%http-proxy-port? port)) +(define (set-http-proxy-port?! port flag) + (set! (%http-proxy-port? port) flag)) diff --git a/module/web/http/dav.scm b/module/web/http/dav.scm new file mode 100644 index 00000000..9adc8b87 --- /dev/null +++ b/module/web/http/dav.scm @@ -0,0 +1,144 @@ +(define-module (web http dav) + :use-module (srfi srfi-9) + :use-module (srfi srfi-88) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module ((ice-9 binary-ports) :select (call-with-output-bytevector)) + :use-module (web request) + :use-module (web response) + :use-module (web client) + :use-module (web uri) + :use-module (sxml simple) + :use-module (sxml xpath) + :use-module ((hnh util) :select (->)) + :export (caldav + user-agent dav + propfind + get-principal + get-calendar-home-set + get-calendar-paths + get-calendar-name + ) + ) + +(define caldav "urn:ietf:params:xml:ns:caldav") +(define user-agent (make-parameter "")) +(user-agent "calp/0.1") + +(define-record-type <info> + (make-info uri-creator password) + info? + (uri-creator uri-creator) + (password info-password) + ) + +(define (with-output-to-bytevector thunk) + (call-with-output-bytevector + (lambda (port) + (with-output-to-port port thunk)))) + +;; Make a webdav HTTP request, body should be a sxml tree without the *TOP* or +;; *PI* element. +(define* (dav uri key: method authorization body (depth 1)) + (define request-body + (if body + (with-output-to-bytevector + (lambda () + (sxml->xml + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + ,body)))) + #f)) + + (define headers + `((user-agent . ,(user-agent)) + (depth . ,(cond (depth number? => number->string) + (else depth))) + ;; (accept . ((*/*))) + (authorization . ,authorization) + ,@(if body + `((content-type . (application/xml (charset . "UTF-8"))) + (content-length . ,(bytevector-length request-body))) + '()))) + + (http-request uri + method: method + body: request-body + headers: headers + keep-alive?: #t + decode-body?: #f + streaming?: #t)) + +(define* (propfind uri resource key: (depth 1) password) + (define authorization + (if password + `(Basic ,password) + #f)) + (define-values (response port) + (dav uri + method: 'PROPFIND + authorization: authorization + depth: depth + body: `(propfind (@ (xmlns "DAV:") + (xmlns:d "DAV:") + (xmlns:c ,caldav)) + (prop (,resource))))) + (unless (= 207 (response-code response)) + (scm-error 'dav-error "propfind" + "HTTP error ~a: ~a" + (list + (response-code response) + (response-reason-phrase response)) + (list response))) + (xml->sxml port + declare-namespaces?: #t + trim-whitespace?: #t + namespaces: `((d . "DAV:") + (c . ,caldav)))) + + +;; (define (get-collections) +;; (-> (propfind "/" 'resourcetype) +;; ((sxpath '(// (d:response (// d:resourcetype d:collection)) +;; d:href *text*))))) + +;; => ((d:resourcetype (d:collection))) + +(define* (get-principal uri key: password) + (-> (propfind uri 'current-user-principal + depth: 0 + password: password) + ((sxpath '(// (d:response (d:href (equal? "/"))) + // + d:prop d:current-user-principal + d:href *text*))) + car)) + +(define* (get-calendar-home-set principal-uri key: password) + (-> (propfind principal-uri + 'c:calendar-home-set + password: password) + ((sxpath `(// (d:response (d:href + (equal? ,(uri-path principal-uri)))) + // d:prop c:calendar-home-set + d:href *text* + ))) + car)) + +(define* (get-calendar-paths calendar-home-set-uri key: password) + (-> (propfind calendar-home-set-uri + 'resourcetype + depth: "infinity" + password: password) + ((sxpath '(// (d:response (// d:resourcetype c:calendar)) + d:href *text*))))) + +;; => ("Calendar") +(define* (get-calendar-name calendar-path + key: password) + (-> (propfind calendar-path 'displayname + depth: 0 + password: password) + ((sxpath '(// d:response // d:prop d:displayname *text*))) + car)) + + diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index feba3f19..a36efaef 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -145,6 +145,8 @@ ;; TODO propper logging (display (format #f "[~a] ~a ~a:~a~a?~a~%" + ;; TODO does this even work? Maybe it works due to datetime + ;; being included at all expansion points. (datetime->string (current-datetime)) r:method r:host r:port r:path (or r:query "")) (current-error-port)) @@ -164,13 +166,14 @@ ;; When content-type is application/x-www-form-urlencoded, ;; decode them, and add it to the argument list - (let ((content-type (assoc-ref r:headers 'content-type))) - (when content-type - (let ((type args (car+cdr content-type))) - (when (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - (parse-query (bytevector->string body encoding) - encoding))))))))))) + (cond ((assoc-ref r:headers 'content-type) + => (lambda (content-type) + (let ((type args (car+cdr content-type))) + (case type + ((application/x-www-form-urlencoded) + (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) + (parse-query (bytevector->string body encoding) + encoding))))))))))))) (case-lambda ((headers body new-state) (values headers body new-state)) ((headers body) (values headers body state)) diff --git a/module/web/http/status-codes.scm b/module/web/http/status-codes.scm new file mode 100644 index 00000000..86be694f --- /dev/null +++ b/module/web/http/status-codes.scm @@ -0,0 +1,87 @@ +(define-module (web http status-codes) + :use-module (srfi srfi-88) + :export (http-status-codes + http-status-phrase + http-status-line)) + +;;; https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml +;;; DAV: RFC4918 + +(define http-status-codes + '((100 . "Continue") + (101 . "Switching Protocols") + (102 . "Processing") ;RFC2518 + (103 . "Early Hints") ;RFC8297 + + (200 . "OK") + (201 . "Created") + (202 . "Accepted") + (203 . "Non-Authoritative Information") + (204 . "No Content") + (205 . "Reset Content") + (206 . "Partial Content") + (207 . "Multi-Status") ;DAV + (208 . "Already Reported") ;RFC5842 + (226 . "IM Used") ;RFC3229 + + (300 . "Multiple Choices") + (301 . "Moved Permanently") + (302 . "Found") + (303 . "See Other") + (304 . "Not Modified") + (305 . "Use Proxy") + (306 . "(Unused)") + (307 . "Temporary Redirect") + (308 . "Permanent Redirect") + + (400 . "Bad Request") + (401 . "Unauthorized") + (402 . "Payment Required") + (403 . "Forbidden") + (404 . "Not Found") + (405 . "Method Not Allowed") + (406 . "Not Acceptable") + (407 . "Proxy Authentication Required") + (408 . "Request Timeout") + (409 . "Conflict") + (410 . "Gone") + (411 . "Length Required") + (412 . "Precondition Failed") ;Extended by DAV + (413 . "Request Entity Too Large") + (414 . "Request-URI Too Long") ;Extended by DAV + (415 . "Unsupported Media Type") + (416 . "Requested Range Not Satisfiable") + (417 . "Expectation Failed") + (418 . "I'm a teapot") ;RFC7168 + (421 . "Misdirection Request") + (422 . "Unprocessable Content") + (423 . "Locked") ;DAV + (424 . "Failed Dependency") ;DAV + (425 . "Too Early") ;RFC8470 + (426 . "Upgrade Required") + (428 . "Precondition Failed") ;RFC6585 + (429 . "Too Many Requests") ;RFC6585 + (431 . "Request Header Fields Too Large") ;RFC6585 + (451 . "Unavailable For Legal Reasons") ;RFC7225 + + (500 . "Internal Server Error") + (501 . "Not Implemented") + (502 . "Bad Gateway") + (503 . "Service Unavailable") + (504 . "Gateway Timeout") + (505 . "HTTP Version Not Supported") + (506 . "Variant Also Negotiates") ;RFC2295 + (507 . "Insufficient Storage") ;DAV + (508 . "Loop Detected") ;RFC5842 + (510 . "Not Extended") ;RFC2774 (OBSOLETED) + (511 . "Network Authentication Required") ;RFC6585 + )) + + +(define (http-status-phrase code) + (or (assoc-ref http-status-codes code) + "")) + +(define* (http-status-line code optional: msg) + (format #f "HTTP/1.1 ~a ~a" code + (or msg (http-status-phrase code)))) |