From 228d485e10f44b402843badabba4f09599f3c2a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 5 May 2020 21:34:52 +0200 Subject: Change to only call get-datetime in parse. --- module/vcomponent/parse.scm | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) (limited to 'module/vcomponent/parse.scm') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index b5bb17e9..a21d6ca1 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -118,10 +118,18 @@ (let ((type (and=> (prop vline 'VALUE) car))) (if (or (and=> type (cut string=? <> "DATE-TIME")) (string-contains (value vline) "T")) - (set! (value vline) (parse-ics-datetime (value vline) tz) + ;; TODO TODO TODO + ;; 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. + ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, + ;; since we don't want to lose that information. + (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) (prop vline 'VALUE) 'DATE-TIME) (set! (value vline) (parse-ics-date (value vline)) - (prop vline 'VALUE) 'DATE))))])) + (prop vline 'VALUE) 'DATE))) + )])) ;; Reads a vcomponent from the given port. (define-public (parse-calendar port) -- cgit v1.2.3 From 17417228af681fabfeaa49b75d7c04f1838e8e4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 8 May 2020 19:35:37 +0200 Subject: Remove unused with-vline-tz. --- module/vcomponent/parse.scm | 4 ---- 1 file changed, 4 deletions(-) (limited to 'module/vcomponent/parse.scm') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index a21d6ca1..2fdd03a8 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -54,10 +54,6 @@ ;; (set-param-table! ctx (make-hash-table)) ) -(define-macro (with-vline-tz object . body) - `(let-env ((TZ (and=> (prop ,object 'TZID) car))) - ,@body)) - -- cgit v1.2.3 From 2cfbec3682b93cdf20e7c1135222070acec634b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 02:53:24 +0200 Subject: Move vcalendar parse code into own file. --- module/vcomponent/parse.scm | 310 +------------------------------------------- 1 file changed, 4 insertions(+), 306 deletions(-) (limited to 'module/vcomponent/parse.scm') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 2fdd03a8..94eaaef2 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,323 +1,21 @@ (define-module (vcomponent parse) - :use-module ((rnrs io ports) :select (get-u8)) :use-module (rnrs bytevectors) :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (datetime) - :use-module (datetime util) - :use-module (srfi srfi-26) + :use-module ((ice-9 hash-table) :select (alist->hash-table)) :use-module ((ice-9 rdelim) :select (read-line)) - :use-module ((ice-9 textual-ports) :select (unget-char)) :use-module ((ice-9 ftw) :select (scandir ftw)) :use-module (util) :use-module (util time) - :use-module (util strbuf) :use-module (util exceptions) :use-module (vcomponent base) - :use-module (vcomponent datetime) - :use-module (datetime util) - ) - -(use-modules ((rnrs base) #:select (assert))) - - - -(define-record-type - (make-parse-ctx% filename row col ctx line-key param-key param-table) - parse-ctx? - (filename get-filename) ; string - (row get-row set-row!) ; [0, ] - (col get-col set-col!) ; [1, ) - (ctx get-ctx set-ctx!) ; '(key value param-name param-value escape) - (line-key get-line-key set-line-key!) ; string - (param-key get-param-key set-param-key!) ; string - (param-table get-param-table set-param-table!) ; hash-map + :use-module (vcomponent parse old) + :re-export (parse-calendar) ) -(define (make-parse-ctx filename) - (make-parse-ctx% filename 1 0 'key - #f #f (make-hash-table))) - -(define (increment-column! ctx) - (set-col! ctx (1+ (get-col ctx)))) - -(define (increment-row! ctx) - (set-col! ctx 0) - (set-row! ctx (1+ (get-row ctx)))) - -(define (ctx-dump-strings! ctx) - (set-line-key! ctx "") - (set-param-key! ctx "") - ;; (set-param-table! ctx (make-hash-table)) - ) - - - - -(define (fold-proc ctx c) - ;; First extra character optional read is to get the \n if our line - ;; ended with \r\n. Secound read is to get the first character of the - ;; next line. The initial \r which might recide in @var{c} is discarded. - (let ((pair (cons (if (char=? #\newline (integer->char c)) - c (get-u8 (current-input-port))) - (get-u8 (current-input-port))))) - (increment-row! ctx) - (cond [(not (char=? #\newline (integer->char (car pair)))) - (error "Expected newline after CR")] - - ;; The standard (3.4, l. 2675) says that each icalobject must - ;; end with CRLF. My files however does not. This means that - ;; an EOF can immideately follow a \n\r pair. But this case is the - ;; same as that we are at the end of line, so we spoof it and let - ;; the regular parser loop handle it. - [(eof-object? (cdr pair)) - 'end-of-line] - - ;; Following line begins with a whitespace character, - ;; meaning that we don't break the logical line here. - [(memv (integer->char (cdr pair)) '(#\space #\tab)) - (increment-column! ctx) ; since we just read the space - 'fold] - - [else - ;; TODO check if this failed, and signal a writeback error - (unget-char (current-input-port) - (integer->char (cdr pair))) - - 'end-of-line]))) - -(define (handle-value! key vline strbuf) - (case key - ;; As far as I can tell the RFC says nothing about special - ;; encoding for individual fields. It mentieons UTF-8, and - ;; that transfer encoding should be set in the mime-headers. - ;; That however seems like a breach of abstractions. - ;; Currently I allow a CHARSET property on SUMMARY fields, - ;; since I know that at least www.lysator.liu.se/alma/alma.cgi - ;; uses it. - [(SUMMARY) - (cond [(and=> (prop vline 'CHARSET) car) - => (lambda (encoding) - (set! (value vline) - (strbuf->string strbuf ((@ (rnrs io ports) make-transcoder) - encoding))))])] - - [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) - - ;; '("Africa/Ceuta" "Europe/Stockholm" "local") - (let ((tz (or (and=> (prop vline 'TZID) car) - (and (string= "Z" (string-take-right (value vline) 1)) "UTC")))) - - (let ((type (and=> (prop vline 'VALUE) car))) - (if (or (and=> type (cut string=? <> "DATE-TIME")) - (string-contains (value vline) "T")) - ;; TODO TODO TODO - ;; 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. - ;; We sohuld however save the original datetime in a file like X-HNH-DTSTART, - ;; since we don't want to lose that information. - (set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz)) - (prop vline 'VALUE) 'DATE-TIME) - (set! (value vline) (parse-ics-date (value vline)) - (prop vline 'VALUE) 'DATE))) - )])) - -;; Reads a vcomponent from the given port. -(define-public (parse-calendar port) - ;; (report-time! "Parsing ~a" port) - (with-input-from-port port - (lambda () - (let ((component (make-vcomponent)) - (ctx (make-parse-ctx (port-filename port))) - (strbuf (make-strbuf))) - (parameterize ((warning-handler - (lambda (fmt . args) - (format #f - "== PARSE WARNING == -filename = ~a -row ~a column ~a ctx = ~a -~a ; ~a = ... : ... -~?~%~%" - (get-filename ctx) - (get-row ctx) (get-col ctx) (get-ctx ctx) - (get-line-key ctx) (get-param-key ctx) - fmt args)))) - (with-throw-handler #t - (lambda () - (while #t - (let ((c (get-u8 (current-input-port)))) - (cond - - ;; End of file - [(eof-object? c) - ;; == NOTE == - ;; We never check the final line here. But since it - ;; ALWAYS should be "END:VCOMPONENT", and we do all - ;; the setup at creation this shouldn't be a problem. - (let ((component - (case (get-ctx ctx) - ;; Line ended before we came here, get the actual root - ;; component (instead of our virtual one: - [(key) (car (children component))] - ;; Line wasn't ended before we get here, so our current - ;; component is our "actual" root. NOTE that this never - ;; actually finalizes the root object, which matters if - ;; if do something with the finalizer below. - ;; At the time of writing we just set the parent. - [(value) component] - [else - => (lambda (a) - (scm-error - 'wrong-type-arg "parse-break" - (string-append - "Bad context at end of file. " - "Expected `key' or `value', got ~a") - (list a) #f))]))) - ;; == NOTE == - ;; This sets to the VCALENDAR, which is correct, - ;; but the program later squashes together everything - ;; and drops this information. - (set! (attr component 'X-HNH-FILENAME) (get-filename ctx) - (parent component) #f) - (break component))] - - ;; End of line - [(memv (integer->char c) '(#\return #\newline)) - (case (fold-proc ctx c) - [(end-of-line) - (let ((str (strbuf->string strbuf))) - (cond [(and (eq? 'key (get-ctx ctx)) - (string-null? str)) - ;; I believe that an empty line is against the standard - ;; in every way. But it's nice to handle it. - (warning "Unexpected completely empty line")] - - [(eq? 'BEGIN (get-line-key ctx)) - (let ((child (make-vcomponent (string->symbol str)))) - (add-child! component child) - (set! component child))] - - [(eq? (get-line-key ctx) 'END) - - ;; Ensure that we have a DTEND - ;; TODO Objects aren't required to have a DTEND, or a DURATION. - ;; write fancier code which acknoledges this. - (when (and (eq? 'VEVENT (type component)) - (not (attr component 'DTEND))) - (set! (attr component 'DTEND) - (let ((start (attr component 'DTSTART))) - ;; p. 54, 3.6.1 - ;; If DTSTART is a date then it's an all - ;; day event. If DTSTART instead is a - ;; datetime then the event has a length - ;; of 0? - (if (date? start) - (date+ start (date day: 1)) - (datetime+ start (datetime time: (time hour: 1))))))) - - (set! component (parent component))] - - [else ; Regular key-value line - (let ((key (get-line-key ctx)) - (vline (make-vline str (get-param-table ctx)))) - ;; Type specific processing - (handle-value! key vline strbuf) - - ;; From RFC 5545 ยง3.6.1 - ;; DTEND and DURATION are mutually exclusive - ;; DTSTART is required to exist while the other two are optional. - - ;; Allowed (some) repeated keys - (if (memv key '(EXDATE ATTENDEE)) - (aif (attr* component key) - ;; updates the current vline - ;; NOTE that this discards any properties belonging to this object - ;; TODO a more propper way to do it would be to store multiple vline - ;; objects for a given key. - (set! (value it) (cons (value vline) (value it))) - (begin (mod! (value vline) list) - (set-vline! component key vline))) - ;; Keys which aren't allowed to be repeated. - (begin - (awhen (attr* component key) - (warning "Key ~a encountered more than once, overriding old value [~a] with [~a]" - key (value it) (value vline))) - (set-vline! component key vline)))) - (set-param-table! ctx (make-hash-table))]) - - (strbuf-reset! strbuf) - (ctx-dump-strings! ctx) - (set-ctx! ctx 'key))] - [(fold) 'noop] ; Good case, here to catch errors in else - [else => (lambda (a) (error "Bad return from fold, unexpected" a))])] - - ;; Escaped characters - [(char=? #\\ (integer->char c)) - (case (integer->char (get-u8 (current-input-port))) - ;; Escape character '\' and escaped token sepparated by a newline - ;; (since the standard for some reason allows that (!!!)) - ;; We are at least guaranteed that it's a folded line, so just - ;; unfold it and continue trying to find a token to escape. - [(#\return #\newline) - => (lambda (c) - (case (fold-proc ctx (char->integer c)) - [(end-of-line) - (throw 'escape-error "ESC before not folded line")] - [(fold) - (increment-column! ctx) - (strbuf-append! strbuf (get-u8 (current-input-port)))]))] - - [(#\n #\N) (strbuf-append! strbuf (char->integer #\newline))] - [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))] - [else => (lambda (c) (warning "Non-escapable character: ~a" c))]) - (increment-column! ctx)] - - ;; Delimiter between param key and param value - [(and (eq? (get-ctx ctx) 'param-name) - (char=? #\= (integer->char c))) - (set-param-key! ctx (string->symbol (strbuf->string strbuf))) - (strbuf-reset! strbuf) - (set-ctx! ctx 'param-value)] - - ;; Delimiter between parameters (;), or between - ;; "something" and attribute value (:) - [(and (memv (integer->char c) '(#\: #\;)) - (memv (get-ctx ctx) '(param-value key))) - (case (get-ctx ctx) - [(param-value) - (hashq-set! (get-param-table ctx) - (get-param-key ctx) - (strbuf->string strbuf)) - (strbuf-reset! strbuf)] - [(key) - (set-line-key! ctx (string->symbol (strbuf->string strbuf))) - (strbuf-reset! strbuf)]) - - (set-ctx! ctx (case (integer->char c) - [(#\:) 'value] - [(#\;) 'param-name]))] - - ;; Regular character - [else - (strbuf-append! strbuf c) - (increment-column! ctx)])))) - - (lambda _ - ;; display is atomic, format isn't - (display - (format #f - "== PARSE ERROR == -filename = ~a -row ~a column ~a ctx = ~a -~a ; ~a = ... : ...~%~%" - (get-filename ctx) - (get-row ctx) (get-col ctx) (get-ctx ctx) - (get-line-key ctx) (get-param-key ctx)))))))))) +(use-modules ((rnrs base) #:select (assert))) -- cgit v1.2.3 From bba0ac5316239f121e0413325c03090df7a97f2e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 05:17:02 +0200 Subject: Set X-HNH-FILENAME outside parse-calendar. --- module/vcomponent/parse.scm | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) (limited to 'module/vcomponent/parse.scm') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 94eaaef2..b2332042 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -11,7 +11,7 @@ :use-module (util exceptions) :use-module (vcomponent base) - :use-module (vcomponent parse old) + :use-module (vcomponent parse new) :re-export (parse-calendar) ) @@ -39,6 +39,7 @@ (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) (children item))) + ;; (assert (eq? 'VCALENDAR (type calendar))) (assert (eq? 'VCALENDAR (type item))) @@ -88,15 +89,17 @@ ;; return calendar) (make-vcomponent) - ((@ (ice-9 threads) par-map) (lambda (fname) - (let ((fullname (/ path fname))) - (let ((cal (call-with-input-file fullname - parse-calendar))) - (set! (attr cal 'COLOR) color - (attr cal 'NAME) name) - cal))) - (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) - (string= "ics" (string-take-right s 3)))))))))) + (map #; (@ (ice-9 threads) par-map) + (lambda (fname) + (let ((fullname (/ path fname))) + (let ((cal (call-with-input-file fullname + parse-calendar))) + (set! (attr cal 'COLOR) color + (attr cal 'NAME) name + (attr cal 'X-HNH-FILENAME) fullname) + cal))) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3)))))))))) ;; Parse a vdir or ics file at the given path. (define-public (parse-cal-path path) -- cgit v1.2.3 From c1feb55a2013116c3291cf0df26f9ab39ad3e8c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 21:43:16 +0200 Subject: New parser now on feature parity with old. --- module/vcomponent/parse.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'module/vcomponent/parse.scm') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index b2332042..906936d9 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -15,8 +15,6 @@ :re-export (parse-calendar) ) -(use-modules ((rnrs base) #:select (assert))) - -- cgit v1.2.3 From 742ae45ce7bdaae3c95a4a74afa5d17381fc76b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 22:16:24 +0200 Subject: Remove old parser, rename new parser to component. --- module/vcomponent/parse.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'module/vcomponent/parse.scm') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 906936d9..3bf444c9 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -11,7 +11,7 @@ :use-module (util exceptions) :use-module (vcomponent base) - :use-module (vcomponent parse new) + :use-module (vcomponent parse component) :re-export (parse-calendar) ) -- cgit v1.2.3 From 4526a54ef07f2dd30bc61cc34934a157e02ab446 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 May 2020 22:18:48 +0200 Subject: Add short commentary on difference between parse and parse/component. --- module/vcomponent/parse.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'module/vcomponent/parse.scm') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 3bf444c9..9e5be8a3 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,3 +1,9 @@ +;;; 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. +;;; Code: + (define-module (vcomponent parse) :use-module (rnrs bytevectors) :use-module (srfi srfi-1) -- cgit v1.2.3