From d0fef42e07614e88fe237571867123b8229c24d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 6 Jul 2020 01:22:13 +0200 Subject: Rename parse component to parse ical. --- module/vcomponent/parse.scm | 4 +- module/vcomponent/parse/component.scm | 307 ---------------------------------- module/vcomponent/parse/ical.scm | 305 +++++++++++++++++++++++++++++++++ tests/xcal.scm | 2 +- 4 files changed, 308 insertions(+), 310 deletions(-) delete mode 100644 module/vcomponent/parse/component.scm create mode 100644 module/vcomponent/parse/ical.scm diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 7b2d7fc5..0b5f5529 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,7 +1,7 @@ ;;; Commentary: ;; Code for parsing vdir's and icalendar files. ;; This module handles the finding of files, while -;; (vcomponent parse component) handles reading data from icalendar files. +;; (vcomponent parse ical) handles reading data from icalendar files. ;;; Code: (define-module (vcomponent parse) @@ -17,7 +17,7 @@ :use-module (util exceptions) :use-module (vcomponent base) - :use-module (vcomponent parse component) + :use-module (vcomponent parse ical) :re-export (parse-calendar) ) diff --git a/module/vcomponent/parse/component.scm b/module/vcomponent/parse/component.scm deleted file mode 100644 index 41ef30f5..00000000 --- a/module/vcomponent/parse/component.scm +++ /dev/null @@ -1,307 +0,0 @@ -;;; TODO rename to (vcomponent parse ical)? To work nices alongside -;;; (vcomponent parse xcal) -(define-module (vcomponent parse component) - :use-module (util) - :use-module (util exceptions) - :use-module ((ice-9 rdelim) :select (read-line)) - :use-module (vcomponent base) - :use-module (datetime) - :use-module (srfi srfi-1) - :use-module (srfi srfi-9 gnu) - :use-module (srfi srfi-26) - :use-module (vcomponent parse types) - :use-module (vcomponent geo) - ) - -;; TODO rename to parse-vcomponent, or parse-ical (?). -(define-public (parse-calendar port) - (parse (map tokenize (read-file port)))) - -(define-immutable-record-type - (make-line string file line) - line? - (string get-string) - (file get-file) - (line get-line)) - - -;; port → (list ) -(define (read-file port) - (define fname (port-filename port)) - (let loop ((line-number 1) (done '())) - (let ((line (read-line port))) - (if (eof-object? line) - (reverse! done) - (let ((line (string-trim-right line))) - (loop - (1+ line-number) - (if (char=? #\space (string-ref line 0)) - ;; Line Wrapping - ;; TODO if the line is split inside a unicode character - ;; then this produces multiple broken unicode characters. - ;; It could be solved by checking the start of the new line, - ;; and the tail of the old line for broken char - (cons (make-line (string-append (get-string (car done)) - (string-drop line 1)) - fname - (get-line (car done))) - (cdr done)) - (cons (make-line line fname line-number) - done)))))))) - -(define-immutable-record-type - (make-tokens metadata data) - tokens? - (metadata get-metadata) ; - (data get-data) ; (key kv ... value) - ) - -;; (list ) → (list ) -(define (tokenize line-obj) - (define line (get-string line-obj)) - (define colon-idx (string-index line #\:)) - (define semi-idxs - (let loop ((idx 0)) - (aif (string-index line #\; idx colon-idx) - (cons it (loop (1+ it))) - (list colon-idx (string-length line))))) - (make-tokens - line-obj - (map (lambda (start end) - (substring line (1+ start) end)) - (cons -1 semi-idxs) - semi-idxs))) - - -#; -'(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - ) - -(define (list-parser symbol) - (let ((parser (get-parser symbol))) - (lambda (params value) - (map (lambda (v) (parser params v)) - (string-split value #\,))))) - -(define* (enum-parser enum optional: (allow-other #t)) - (let ((parser (compose car (get-parser 'TEXT)))) - (lambda (params value) - (let ((vv (parser params value))) - (when (list? vv) - (throw 'parse-error "List in enum field")) - (let ((v (string->symbol vv))) - (unless (memv v enum) - (warning "~a ∉ { ~{~a~^, ~} }" - v enum)) - v))))) - -;; params could be made optional, with an empty hashtable as default -(define (build-vline key value params) - (let ((parser - (cond - [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] - - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE - CREATED DTSTAMP LAST-MODIFIED - ;; only on VALARM - ACKNOWLEDGED - )) - (get-parser 'DATE-TIME)] - - [(memv key '(EXDATE)) - (list-parser 'DATE-TIME)] - - [(memv key '(TRIGGER DURATION)) - (get-parser 'DURATION)] - - [(memv key '(FREEBUSY)) - (list-parser 'PERIOD)] - - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION - LOCATION SUMMARY TZID TZNAME - CONTACT RELATED-TO UID)) - (lambda (params value) - (let ((v ((get-parser 'TEXT) params value))) - (unless (= 1 (length v)) - (warning "List in non-list field: ~s" v)) - (car v)))] - - ;; TEXT, but allow a list - [(memv key '(CATEGORIES RESOURCES)) - (get-parser 'TEXT)] - - [(memv key '(VERSION)) - (lambda (params value) - (let ((v (car ((get-parser 'TEXT) params value)))) - (unless (and (string? v) (string=? "2.0" v)) - #f - ;; (warning "File of unsuported version. Proceed with caution") - ) - v))] - - [(memv key '(TRANSP)) - (enum-parser '(OPAQUE TRANSPARENT) #f)] - - [(memv key '(CLASS)) - (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))] - - [(memv key '(PARTSTAT)) - (enum-parser '(NEEDS-ACTION - ACCEPTED DECLINED - TENTATIVE DELEGATED - IN-PROCESS))] - - [(memv key '(STATUS)) - (enum-parser '(TENTATIVE - CONFIRMED CANCELLED - NEEDS-ACTION COMPLETED IN-PROCESS - DRAFT FINAL CANCELED))] - - [(memv key '(REQUEST-STATUS)) - (throw 'parse-error "TODO Implement REQUEST-STATUS")] - - [(memv key '(ACTION)) - (enum-parser '(AUDIO DISPLAY EMAIL - NONE ; I don't know where NONE is from - ; but it appears to be prevelant. - ))] - - [(memv key '(TZOFFSETFROM TZOFFSETTO)) - (get-parser 'UTC-OFFSET)] - - [(memv key '(ATTACH TZURL URL)) - (get-parser 'URI)] - - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) - (get-parser 'INTEGER)] - - [(memv key '(GEO)) - ;; two semicolon sepparated floats - (lambda (params value) - (let* (((left right) (string-split value #\;))) - (make-geo ((get-parser 'FLOAT) params left) - ((get-parser 'FLOAT) params right))))] - - [(memv key '(RRULE)) - (get-parser 'RECUR)] - - [(memv key '(ORGANIZER ATTENDEE)) - (get-parser 'CAL-ADDRESS)] - - [(x-property? key) - (compose car (get-parser 'TEXT))] - - [else - (warning "Unknown key ~a" key) - (compose car (get-parser 'TEXT))]))) - - ;; If we produced a list create multiple VLINES from it. - ;; NOTE that the created vlines share parameter tables. - ;; TODO possibly allow vlines to reference each other, to - ;; indicate that all these vlines are the same. - (let ((parsed (parser params value))) - (if (list? parsed) - (apply values - (map (lambda (p) (make-vline key p params)) - parsed)) - (make-vline key parsed params))))) - -;; (parse-itemline '("DTEND" "20200407T130000")) -;; => DTEND -;; => "20200407T130000" -;; => # -(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)))))) - - -;; (list ) → -(define (parse lst) - (let loop ((lst lst) - (stack '())) - (if (null? lst) - stack - (let* ((head* (car lst)) - (head (get-data head*))) - (catch 'parse-error - (lambda () - (parameterize - ((warning-handler - (lambda (fmt . args) - (let ((linedata (get-metadata head*))) - (format - #f "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*)) - - ;; See RFC 5545 p.53 for list of all repeating types - ;; (for vcomponent) - (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)]))) - (lambda (err fmt . args) - (let ((linedata (get-metadata head*))) - (display (format - #f "ERROR parse error around ~a - ~? - line ~a ~a - Defaulting to string~%" - (get-string linedata) - fmt args - (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))))))))) diff --git a/module/vcomponent/parse/ical.scm b/module/vcomponent/parse/ical.scm new file mode 100644 index 00000000..a07487f0 --- /dev/null +++ b/module/vcomponent/parse/ical.scm @@ -0,0 +1,305 @@ +(define-module (vcomponent parse ical) + :use-module (util) + :use-module (util exceptions) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (vcomponent base) + :use-module (datetime) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-26) + :use-module (vcomponent parse types) + :use-module (vcomponent geo) + ) + +;; TODO rename to parse-vcomponent, or parse-ical (?). +(define-public (parse-calendar port) + (parse (map tokenize (read-file port)))) + +(define-immutable-record-type + (make-line string file line) + line? + (string get-string) + (file get-file) + (line get-line)) + + +;; port → (list ) +(define (read-file port) + (define fname (port-filename port)) + (let loop ((line-number 1) (done '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse! done) + (let ((line (string-trim-right line))) + (loop + (1+ line-number) + (if (char=? #\space (string-ref line 0)) + ;; Line Wrapping + ;; TODO if the line is split inside a unicode character + ;; then this produces multiple broken unicode characters. + ;; It could be solved by checking the start of the new line, + ;; and the tail of the old line for broken char + (cons (make-line (string-append (get-string (car done)) + (string-drop line 1)) + fname + (get-line (car done))) + (cdr done)) + (cons (make-line line fname line-number) + done)))))))) + +(define-immutable-record-type + (make-tokens metadata data) + tokens? + (metadata get-metadata) ; + (data get-data) ; (key kv ... value) + ) + +;; (list ) → (list ) +(define (tokenize line-obj) + (define line (get-string line-obj)) + (define colon-idx (string-index line #\:)) + (define semi-idxs + (let loop ((idx 0)) + (aif (string-index line #\; idx colon-idx) + (cons it (loop (1+ it))) + (list colon-idx (string-length line))))) + (make-tokens + line-obj + (map (lambda (start end) + (substring line (1+ start) end)) + (cons -1 semi-idxs) + semi-idxs))) + + +#; +'(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + ) + +(define (list-parser symbol) + (let ((parser (get-parser symbol))) + (lambda (params value) + (map (lambda (v) (parser params v)) + (string-split value #\,))))) + +(define* (enum-parser enum optional: (allow-other #t)) + (let ((parser (compose car (get-parser 'TEXT)))) + (lambda (params value) + (let ((vv (parser params value))) + (when (list? vv) + (throw 'parse-error "List in enum field")) + (let ((v (string->symbol vv))) + (unless (memv v enum) + (warning "~a ∉ { ~{~a~^, ~} }" + v enum)) + v))))) + +;; params could be made optional, with an empty hashtable as default +(define (build-vline key value params) + (let ((parser + (cond + [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] + + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE + CREATED DTSTAMP LAST-MODIFIED + ;; only on VALARM + ACKNOWLEDGED + )) + (get-parser 'DATE-TIME)] + + [(memv key '(EXDATE)) + (list-parser 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-parser 'DURATION)] + + [(memv key '(FREEBUSY)) + (list-parser 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID)) + (lambda (params value) + (let ((v ((get-parser 'TEXT) params value))) + (unless (= 1 (length v)) + (warning "List in non-list field: ~s" v)) + (car v)))] + + ;; TEXT, but allow a list + [(memv key '(CATEGORIES RESOURCES)) + (get-parser 'TEXT)] + + [(memv key '(VERSION)) + (lambda (params value) + (let ((v (car ((get-parser 'TEXT) params value)))) + (unless (and (string? v) (string=? "2.0" v)) + #f + ;; (warning "File of unsuported version. Proceed with caution") + ) + v))] + + [(memv key '(TRANSP)) + (enum-parser '(OPAQUE TRANSPARENT) #f)] + + [(memv key '(CLASS)) + (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))] + + [(memv key '(PARTSTAT)) + (enum-parser '(NEEDS-ACTION + ACCEPTED DECLINED + TENTATIVE DELEGATED + IN-PROCESS))] + + [(memv key '(STATUS)) + (enum-parser '(TENTATIVE + CONFIRMED CANCELLED + NEEDS-ACTION COMPLETED IN-PROCESS + DRAFT FINAL CANCELED))] + + [(memv key '(REQUEST-STATUS)) + (throw 'parse-error "TODO Implement REQUEST-STATUS")] + + [(memv key '(ACTION)) + (enum-parser '(AUDIO DISPLAY EMAIL + NONE ; I don't know where NONE is from + ; but it appears to be prevelant. + ))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-parser 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-parser 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-parser 'INTEGER)] + + [(memv key '(GEO)) + ;; two semicolon sepparated floats + (lambda (params value) + (let* (((left right) (string-split value #\;))) + (make-geo ((get-parser 'FLOAT) params left) + ((get-parser 'FLOAT) params right))))] + + [(memv key '(RRULE)) + (get-parser 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-parser 'CAL-ADDRESS)] + + [(x-property? key) + (compose car (get-parser 'TEXT))] + + [else + (warning "Unknown key ~a" key) + (compose car (get-parser 'TEXT))]))) + + ;; If we produced a list create multiple VLINES from it. + ;; NOTE that the created vlines share parameter tables. + ;; TODO possibly allow vlines to reference each other, to + ;; indicate that all these vlines are the same. + (let ((parsed (parser params value))) + (if (list? parsed) + (apply values + (map (lambda (p) (make-vline key p params)) + parsed)) + (make-vline key parsed params))))) + +;; (parse-itemline '("DTEND" "20200407T130000")) +;; => DTEND +;; => "20200407T130000" +;; => # +(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)))))) + + +;; (list ) → +(define (parse lst) + (let loop ((lst lst) + (stack '())) + (if (null? lst) + stack + (let* ((head* (car lst)) + (head (get-data head*))) + (catch 'parse-error + (lambda () + (parameterize + ((warning-handler + (lambda (fmt . args) + (let ((linedata (get-metadata head*))) + (format + #f "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*)) + + ;; See RFC 5545 p.53 for list of all repeating types + ;; (for vcomponent) + (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)]))) + (lambda (err fmt . args) + (let ((linedata (get-metadata head*))) + (display (format + #f "ERROR parse error around ~a + ~? + line ~a ~a + Defaulting to string~%" + (get-string linedata) + fmt args + (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))))))))) diff --git a/tests/xcal.scm b/tests/xcal.scm index 88c708f4..f11ca1aa 100644 --- a/tests/xcal.scm +++ b/tests/xcal.scm @@ -1,5 +1,5 @@ (((vcomponent parse xcal) sxcal->vcomponent) - ((vcomponent parse component) parse-calendar) + ((vcomponent parse ical) parse-calendar) ((output xcal) vcomponent->sxcal) ((util) ->) ((vcomponent base) -- cgit v1.2.3