blob: efe17f364e5c50b24b23f08c0adb016889d56ba3 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
(define-module (vcomponent formats common types)
:use-module (hnh util)
:use-module (hnh util exceptions)
:use-module (base64)
:use-module (datetime)
:use-module (srfi srfi-9 gnu)
:use-module (datetime timespec)
)
;; BINARY
(define (parse-binary props value)
;; p 30
(unless (string=? "BASE64" (hashq-ref props 'ENCODING))
(warning "Binary field not marked ENCODING=BASE64"))
;; For icalendar no extra whitespace is allowed in a
;; binary field (except for line wrapping). This differs
;; from xcal.
(base64-string->bytevector value))
;; BOOLEAN
(define (parse-boolean props value)
(cond
[(string=? "TRUE" value) #t]
[(string=? "FALSE" value) #f]
[else (warning "~a invalid boolean" value)]))
;; CAL-ADDRESS ⇒ uri
;; DATE
(define (parse-date props value)
(parse-ics-date value))
;; DATE-TIME
(define (parse-datetime props value)
(define parsed
(parse-ics-datetime
value (hashq-ref props 'TZID #f)))
(hashq-set! props '-X-HNH-ORIGINAL parsed)
(get-datetime parsed))
;; DURATION
(define (parse-duration props value)
((@ (vcomponent duration) parse-duration)
value))
;; FLOAT
;; Note that this is overly permissive, and flawed.
;; Numbers such as @expr{1/2} is accepted as exact
;; rationals. Some floats are rounded.
(define (parse-float props value)
(string->number value))
;; INTEGER
(define (parse-integer props value)
(let ((n (string->number value)))
(unless (integer? n)
(warning "Non integer as integer"))
n))
;; PERIOD
(define (parse-period props value)
(let* (((left right) (string-split value #\/)))
;; TODO timezones? VALUE=DATE?
(cons (parse-ics-datetime left)
((if (memv (string-ref right 0)
'(#\P #\+ #\-))
(@ (vcomponent duration) parse-duration)
parse-ics-datetime)
right))))
;; RECUR
(define (parse-recur props value)
((@ (vcomponent recurrence parse) parse-recurrence-rule) value))
;; TEXT
;; TODO quoted strings
(define (parse-text props value)
(let loop ((rem (string->list value))
(str '())
(done '()))
(if (null? rem)
(cons (reverse-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
(define (parse-time props value)
;; TODO time can have timezones...
(parse-ics-time value))
;; URI
(define (parse-uri props value)
value)
;; UTC-OFFSET
(define (parse-utc-offset props value)
(make-timespec
(time
hour: (string->number (substring value 1 3))
minute: (string->number (substring value 3 5))
second: (if (= 7 (string-length value))
(string->number (substring value 5 7))
0))
;; sign
(string->symbol (substring value 0 1))
#\z))
(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)))
|
