From d00fea566004e67161ee45246b239fff5d416b0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 21 Dec 2021 16:17:28 +0100 Subject: Cleanup modules. Primarly this moves all vcompenent input and output code to clearly labeled modules, instead of being spread out. At the same time it also removes a handfull of unused procedures. --- module/vcomponent/formats/ical/parse.scm | 336 +++++++++++++++++++++++++++++++ 1 file changed, 336 insertions(+) create mode 100644 module/vcomponent/formats/ical/parse.scm (limited to 'module/vcomponent/formats/ical/parse.scm') diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm new file mode 100644 index 00000000..d76044a3 --- /dev/null +++ b/module/vcomponent/formats/ical/parse.scm @@ -0,0 +1,336 @@ +(define-module (vcomponent formats ical parse) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (calp util exceptions) + :use-module (calp util) + :use-module (datetime) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + :use-module (srfi srfi-9 gnu) + :use-module (vcomponent base) + :use-module (vcomponent geo) + :use-module (vcomponent formats common types) + ) + +(define string->symbol + (let ((ht (make-hash-table 1000))) + (lambda (str) + (or (hash-ref ht str) + (let ((symb ((@ (guile) string->symbol) str))) + (hash-set! ht str symb) + symb))))) + +;; 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 ((ostr (open-output-string))) + (define ret + (let loop ((line (read-line port))) + (if (eof-object? line) + 'eof + (let ((line (string-trim-right line #\return))) + (let ((next (peek-char port))) + (display line ostr) + (cond ((eof-object? next) + 'final-line) + ;; Line Wrapping + ;; If the first character on a line is space (whitespace?) + ;; then it's a continuation line, and should be merged + ;; with the one preceeding it. + ;; 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 + ;; TODO what about other leading whitespace? + ((char=? next #\space) + (read-char port) ; discard leading whitespace + (loop (read-line port))) + (else + ;; (unread-char next) + 'line))))))) + (case ret + ((line) + (let ((str (get-output-string ostr))) + (close-port ostr) + (loop (1+ line-number) + (cons (make-line str fname line-number) + done)))) + ((eof) + (close-port ostr) + (reverse! done)) + ((final-line) + (let ((str (get-output-string ostr))) + (close-port ostr) + (reverse! (cons (make-line str fname line-number) + done)))))))) + +(define-immutable-record-type + (make-tokens metadata data) + tokens? + (metadata get-metadata) ; + (data get-data) ; (key kv ... value) + ) + +;; → +(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)) + (string-join v ",")))] + + ;; TEXT, but allow a list + [(memv key '(CATEGORIES RESOURCES)) + ;; TODO An empty value should lead to an empty set + ;; currently it seems to lead to '("") + (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))))))))) -- cgit v1.2.3