From 141c95d5c360e5640d184eb3d6d8a9a84fb4b45d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 14 Jun 2020 02:05:09 +0200 Subject: Map all fields into types. --- module/vcomponent/parse/component.scm | 143 +++++++++++++++++++++++++--------- module/vcomponent/parse/types.scm | 42 +++++++++- 2 files changed, 147 insertions(+), 38 deletions(-) (limited to 'module/vcomponent/parse') diff --git a/module/vcomponent/parse/component.scm b/module/vcomponent/parse/component.scm index 70af3963..9ab9c004 100644 --- a/module/vcomponent/parse/component.scm +++ b/module/vcomponent/parse/component.scm @@ -6,6 +6,7 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (srfi srfi-26) + :use-module (vcomponent parse types) ) (define-public (parse-calendar port) @@ -43,43 +44,115 @@ (cons -1 semi-idxs) semi-idxs)) +(define (x-property? symb) + (string=? "X-" (string-take (symbol->string symb) 2))) + +#; +'(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) + (let ((parser (get-parser 'TEXT))) + (lambda (params value) + (let ((vv (parser params value))) + (when (list? vv) + (error "")) + (let ((v (symbol->string vv))) + (unless (memv v enum) + (warning "")) + v))))) + ;; params could be made optional, with an empty hashtable as default (define (build-vline key value params) - (case key - [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) - - ;; '("Africa/Ceuta" "Europe/Stockholm" "local") - (let ((tz (or (hashq-ref params 'TZID) - (and (string= "Z" (string-take-right value 1)) "UTC")))) - - (let ((type (hashq-ref params 'VALUE))) - (if (or (and=> type (cut string=? <> "DATE-TIME")) - (string-index value #\T)) - ;; we move all parsed datetimes to local time here. This - ;; gives a MASSIVE performance boost over calling get-datetime - ;; in all procedures which want to guarantee local time for proper calculations. - ;; 20s vs 70s runtime on my laptop. - (let ((datetime (parse-ics-datetime value tz))) - (hashq-set! params 'VALUE 'DATE-TIME) - (values (make-vline key (get-datetime datetime) params) - (make-vline (symbol-append 'X-HNH-ORIGINAL- key) datetime params))) - (begin (hashq-set! params 'VALUE 'DATE) - (make-vline key (parse-ics-date value) params)))))] - - [else - (make-vline key - (list->string - (let loop ((rem (string->list value))) - (if (null? rem) - '() - (if (char=? #\\ (car rem)) - (case (cadr rem) - [(#\n #\N) (cons #\newline (loop (cddr rem)))] - [(#\; #\, #\\) => (lambda (c) (cons c (loop (cddr rem))))] - [else => (lambda (c) (warning "Non-escapable character: ~a" c) - (loop (cddr rem)))]) - (cons (car rem) (loop (cdr rem))))))) - params)])) + (let ((parser + (cond + [(hashq-ref params 'TYPE) => get-parser] + + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE + CREATED DTSTAMP LAST-MODIFIED)) + (get-parser 'DATE-TIME)] + + [(memv key '(EXDATE)) + (list-parser 'DATE-TIME)] + + [(memv key '(DURATION)) + (get-parser 'DURATION)] + + [(memv key '(FREEBUSY)) + (list-parser 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION STATUS SUMMARY TZID TZNAME + CONTACT RELATED-TO UID)) + (lambda (params value) + (let ((v ((get-parser 'TEXT) params value))) + (when (list? v) + (warning "List in non-list field")) + v))] + + ;; TEXT, but allow a list + [(memv key '(CATEGORIES RESOURCES)) + (get-parser 'TEXT)] + + [(memv key '(VERSION)) + (lambda (params value) + (let ((v ((get-parser 'TEXT) params value))) + (unless (string=? "2.0" v) + (warning "File of unsuported version. Proceed with caution"))))] + + [(memv key '(TRANSP)) + (enum-parser '(OPAQUE TRANSPARENT))] + + [(memv key '(CLASS)) + (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL) #t)] + + ;; TODO + [(memv key '(REQUEST-STATUS))] + + [(memv key '(ACTION)) + (enum-parser '(AUDIO DISPLAY EMAIL) #t)] + + [(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 #\;))) + (cons ((get-parser 'FLOAT) params left) + ((get-parser 'FLOAT) params right))))] + + [(memv key '(RRULE)) + ;; TODO date/datetime + (get-parser 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-parser 'CAL-ADDRESS)] + + [(x-property? key) + (get-parser 'TEXT)] + + [else + (warning "Unknown key ~a" key) + (get-parser 'TEXT)]))) + (make-vline key (parser params value) params))) ;; (parse-itemline '("DTEND" "20200407T130000")) ;; => DTEND diff --git a/module/vcomponent/parse/types.scm b/module/vcomponent/parse/types.scm index 2468f038..7472b8c2 100644 --- a/module/vcomponent/parse/types.scm +++ b/module/vcomponent/parse/types.scm @@ -4,6 +4,7 @@ :use-module (util base64) :use-module (rnrs io ports) :use-module (datetime) + :use-module (srfi srfi-9 gnu) ) ;; BINARY @@ -65,12 +66,27 @@ ;; RECUR (define (parse-recur props value) - (parse-recurrence-rule value)) + ((@ (vcomponent recurrence parse) parse-recurrence-rule) value)) ;; TEXT -;; TODO quoted strings and escaped chars +;; TODO quoted strings (define (parse-text props value) - value) + (let loop ((rem (string->list value)) + (str '()) + (done '())) + (if (null? rem) + (cons (list->string str) done) + (case (car rem) + [(#\\) + (case (cadr rem) + [(#\n #\N) (loop (cddr rem) (cons #\newline str) done)] + [(#\; #\, #\\) => (lambda (c) (loop (cddr rem) (cons c str) done))] + [else => (lambda (c) (warning "Non-escapable character: ~a" c) + (loop (cddr rem) str done))])] + [(#\,) + (loop (cdr rem) '() (cons (reverse-list->string str) done))] + [else + (loop (cdr rem) (cons (car rem) str) done)])))) ;; TIME @@ -99,3 +115,23 @@ (if (= 7 (string-length value)) (number->string (substring value 5 7)) 0))) + +(define type-parsers (make-hash-table)) +(hashq-set! type-parsers 'BINARY parse-binary) +(hashq-set! type-parsers 'BOOLEAN parse-boolean) +(hashq-set! type-parsers 'CAL-ADDRESS parse-uri) +(hashq-set! type-parsers 'DATE parse-date) +(hashq-set! type-parsers 'DATE-TIME parse-datetime) +(hashq-set! type-parsers 'DURATION parse-duration) +(hashq-set! type-parsers 'FLOAT parse-float) +(hashq-set! type-parsers 'INTEGER parse-integer) +(hashq-set! type-parsers 'PERIOD parse-period) +(hashq-set! type-parsers 'RECUR parse-recur) +(hashq-set! type-parsers 'TEXT parse-text) +(hashq-set! type-parsers 'TIME parse-time) +(hashq-set! type-parsers 'URI parse-uri) +(hashq-set! type-parsers 'UTC-OFFSET parse-utc-offset) + +(define-public (get-parser type) + (or (hashq-ref type-parsers type #f) + (error "No parser for type" type))) -- cgit v1.2.3