source: project/release/4/mbox/trunk/mbox.scm @ 34045

Last change on this file since 34045 was 34045, checked in by Ivan Raikov, 3 years ago

mbox: added test cases

File size: 10.0 KB
Line 
1;;
2;;
3;;  A parser for mbox database files.
4;;
5;;  Based on RFC 4155, "The application/mbox Media Type".
6;;
7;;  Copyright 2010-2017 Ivan Raikov.
8;;
9;;  This program is free software: you can redistribute it and/or
10;;  modify it under the terms of the GNU General Public License as
11;;  published by the Free Software Foundation, either version 3 of the
12;;  License, or (at your option) any later version.
13;;
14;;  This program is distributed in the hope that it will be useful,
15;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
16;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;;  General Public License for more details.
18;;
19;;  A full copy of the GPL license can be found at
20;;  <http://www.gnu.org/licenses/>.
21
22(module mbox
23
24        (
25         mbox-file->messages
26         message? message-envelope message-headers message-body
27         <Mbox> Input+.CoreABNF->Mbox Input+.CoreABNF->Mbox/UTF8
28         )
29
30        (import scheme chicken data-structures posix srfi-1 srfi-14)
31
32        (require-extension typeclass input-classes)
33        (require-library extras abnf abnf-consumers internet-message  )
34                         
35        (import (prefix abnf abnf: ) 
36                (prefix abnf-consumers abnf: ) 
37                (only abnf <CoreABNF> <Token> <CharLex> 
38                      CharLex->CoreABNF Input->Token 
39                      Token->CharLex 
40                      )
41                (only internet-message <InetMessage> CoreABNF->InetMessage CoreABNF->InetMessage/UTF8)
42                (only extras pp fprintf)
43                )
44
45
46(define-record-type message
47  (make-message envelope headers body )
48  message?
49  (envelope     message-envelope )
50  (headers      message-headers )
51  (body         message-body )
52  )
53
54(define-record-printer (message x out)
55  (fprintf out "#(message envelope=~S headers=~S body=~S)"
56           (message-envelope x)
57           ((message-headers x) )
58           ((message-body x) )
59           ))
60
61
62
63(define-class <Mbox> (<InetMessage> M) 
64  mbox-envelope mbox-message-fields
65  mbox-message mbox-file->messages )
66
67
68;; Unix ctime date and time specification
69
70;; Parses a date and time specification of the form
71;;
72;;   Tue Jan 5 18:29:55 2010
73
74;; Matches the abbreviated weekday names
75
76(define=> (day-name <InetMessage>)
77  (abnf:alternatives
78   (lit "Mon")
79   (lit "Tue")
80   (lit "Wed")
81   (lit "Thu")
82   (lit "Fri")
83   (lit "Sat")
84   (lit "Sun")))
85
86;; Matches a day-name
87
88(define=> (day-of-week <InetMessage>)
89  (lambda (day-name)
90    (abnf:bind-consumed-strings->list 
91     'day-of-week 
92     (abnf:bind-consumed->string day-name))))
93
94;; Matches a four digit decimal number
95
96(define=> (year <InetMessage>)
97  (abnf:bind-consumed-strings->list 'year 
98  (abnf:bind-consumed->string 
99   (abnf:repetition-n 4 decimal))))
100
101;; Matches the abbreviated month names
102
103
104(define=> (month-name <InetMessage>)
105  (abnf:alternatives
106   (lit "Jan")
107   (lit "Feb")
108   (lit "Mar")
109   (lit "Apr")
110   (lit "May")
111   (lit "Jun")
112   (lit "Jul")
113   (lit "Aug")
114   (lit "Sep")
115   (lit "Oct")
116   (lit "Nov")
117   (lit "Dec")))
118
119;; Matches a month-name
120
121(define=> (month <InetMessage>)
122  (lambda (month-name)
123    (abnf:bind-consumed-strings->list 'month 
124      (abnf:bind-consumed->string month-name))))
125
126
127;; Matches a one or two digit number
128
129(define=> (day <InetMessage>)
130  (abnf:bind-consumed-strings->list 'day 
131   (abnf:bind-consumed->string 
132    (abnf:variable-repetition 1 2 decimal))))
133
134;; Matches a two-digit number
135
136(define=> (hour <InetMessage>)
137  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
138(define=> (minute <InetMessage>)
139  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
140(define=> (isecond <InetMessage>)
141  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
142
143;; Matches a time-of-day specification of hh:mm or hh:mm:ss.
144
145(define=> (time-of-day  <InetMessage>)
146  (lambda (hour minute isecond)
147    (abnf:bind-consumed-strings->list 'time-of-day 
148    (abnf:concatenation
149     hour (abnf:drop-consumed (char #\:))
150     minute (abnf:optional-sequence 
151             (abnf:concatenation 
152              (abnf:drop-consumed (char #\:))
153              isecond))))))
154
155
156(define=> (between-sp-drop <InetMessage>)
157  (lambda (p)
158    (abnf:concatenation
159     (abnf:drop-consumed (abnf:repetition1 sp))
160     p
161     (abnf:drop-consumed (abnf:repetition sp)))))
162
163(define=> (ctime <InetMessage>)
164  (lambda (between-sp-drop day-of-week month day time-of-day year)
165    (abnf:bind-consumed-pairs->list 'ctime
166      (abnf:concatenation
167       day-of-week 
168       (between-sp-drop month)
169       day
170       (between-sp-drop time-of-day)
171       year))))
172
173
174(define=> (abbrtime  <InetMessage>)
175  (lambda (between-sp-drop day-of-week day year month)
176    (abnf:bind-consumed-pairs->list 'abbrtime
177      (abnf:concatenation
178       day-of-week 
179       (between-sp-drop day)
180       year
181       (between-sp-drop month)))))
182
183
184(define=> (mbox-message-fields <InetMessage>)
185  (fields crlf: lf))
186
187(define=> (address <InetMessage> )
188  (abnf:bind-consumed-pairs->list 'address
189    (abnf:alternatives 
190     addr-spec 
191     (abnf:bind-consumed-strings->list 'local-part
192      (abnf:concatenation
193       (abnf:bind-consumed->string
194        (abnf:concatenation
195         (abnf:repetition1 ftext)))
196       (abnf:drop-consumed 
197        (abnf:repetition wsp)))))))
198 
199
200(define=> (mbox-envelope <InetMessage>)
201  (lambda (address ctime abbrtime)
202    (abnf:bind-consumed-pairs->list 'envelope
203     (abnf:concatenation
204      (abnf:drop-consumed 
205       (abnf:concatenation 
206        (abnf:optional-sequence (char #\newline))
207        (lit "From ")
208        ))
209      address
210      (abnf:alternatives ctime abbrtime)
211      (abnf:drop-consumed lf)))))
212
213
214(define stream-consumed car)
215(define stream-rest cdr)
216
217
218(define (month->number month)
219  (case (string->symbol month)
220    ((Jan) 0)
221    ((Feb) 1)
222    ((Mar) 2)
223    ((Apr) 3)
224    ((May) 4)
225    ((Jun) 5)
226    ((Jul) 6)
227    ((Aug) 7)
228    ((Sep) 8)
229    ((Oct) 9)
230    ((Nov) 10)
231    ((Dec) 11)))
232 
233
234(define (lookup-def x lst)
235  (let ((v (alist-ref x lst)))
236    (and v (if (pair? (cdr v)) v (car v)))))
237
238(define (ctime->seconds lst)
239  (let ((month (lookup-def 'month lst))
240        (day   (lookup-def 'day lst))
241        (time-of-day (lookup-def 'time-of-day lst))
242        (year (lookup-def 'year lst)))
243    (and month day time-of-day year
244         (let ((month (month->number month))
245               (day   (string->number day))
246               (time-of-day (map string->number time-of-day))
247               (year (string->number year)))
248           (let ((t (list->vector
249                    (append time-of-day
250                            (list day month (- year 1900)
251                                  0 0 #f 0)))))
252             
253             (local-time->seconds t)
254             )))))
255                                       
256   
257
258(define (abbrtime->seconds lst)
259  (let ((month (lookup-def 'month lst))
260        (day   (lookup-def 'day lst))
261        (year  (lookup-def 'year lst)))
262    (and month day year
263         (let ((month (month->number month))
264               (day   (string->number day))
265               (year (string->number year)))
266           (local-time->seconds
267            (list->vector
268             (append (list 0 0 0)
269                     (list day month (- year 1900)
270                           0 0 #f 0))))))))
271                                       
272   
273
274(define (make-mbox-envelope x)
275  (let ((alst (and (pair? x) (eq? 'envelope (car x)) (cdr x))))
276    (and alst
277         (let ((ctime (lookup-def 'ctime alst))
278               (abbrtime (lookup-def 'abbrtime alst)))
279           (let ((time-seconds 
280                  (cond (ctime (ctime->seconds ctime))
281                        (abbrtime (abbrtime->seconds abbrtime))
282                        (else #f))))
283             `((time-seconds ,time-seconds) . ,alst))))))
284
285
286(define=> (mbox-message <Input+> )
287
288  (lambda (mbox-envelope mbox-message-fields )
289
290    (lambda (s)
291      (let* ((res (find (string->input-stream "\n\n") s))
292             (s1  (mbox-envelope identity error `(() ,(car res))))
293             (s2  (cadr res)))
294        (and (pair? s1)
295             
296             (make-message
297             
298              (make-mbox-envelope (car (stream-consumed s1)))
299             
300              (lambda () 
301                (mbox-message-fields stream-consumed error
302                                     `(() ,(car (stream-rest s1)))))
303             
304              (let ((parts (map (lambda (x) `(() ,(first x))) s2)))
305                (lambda (#!key (mbox-message-body (lambda (sk fk s) (sk s))))
306                  (concatenate 
307                   (filter-map
308                    (lambda (part) (mbox-message-body stream-consumed (lambda _ #f) part))
309                    parts))))
310             
311              ))))
312  ))
313
314
315(define=> (mbox-file->messages <Input+>)
316
317  (lambda (mbox-message)
318
319    (lambda (filename)
320     
321      (let* ((strm    (file->input-stream filename))
322             (res     (find (string->input-stream "\nFrom ") strm)))
323
324        (let ((lst (cons (list (car res)) (cadr res))))
325
326        (filter-map (compose mbox-message car) lst)
327        ))
328      )))
329
330
331(define (Input+.CoreABNF->Mbox II A)
332
333  (let* ((M   (CoreABNF->InetMessage A))
334
335         (between-sp-drop  (between-sp-drop M))
336         (day-name     (day-name M))
337         (day-of-week  ((day-of-week M) day-name))
338         (day          (day M))
339         (month-name   (month-name M))
340         (month        ((month M) month-name))
341         (year         (year M))
342         (hour         (hour M))
343         (minute       (minute M))
344         (isecond      (isecond M))
345         (time-of-day  ((time-of-day M) hour minute isecond))
346         (ctime        ((ctime M) between-sp-drop day-of-week month day time-of-day year))
347         (abbrtime     ((abbrtime M) between-sp-drop day-of-week day year month))
348         (address      (address M))
349         (mbox-message-fields (mbox-message-fields M))
350         (mbox-envelope ((mbox-envelope M) address ctime abbrtime))
351         (mbox-message ((mbox-message II) 
352                        mbox-envelope mbox-message-fields ))
353         (mbox-file->messages  ((mbox-file->messages II)
354                                mbox-message))
355         )
356
357    (make-<Mbox> M mbox-envelope mbox-message-fields 
358                 mbox-message mbox-file->messages )
359    ))
360
361
362(define (Input+.CoreABNF->Mbox/UTF8 II A)
363
364  (let* ((M   (CoreABNF->InetMessage/UTF8 A))
365
366         (between-sp-drop  (between-sp-drop M))
367         (day-name     (day-name M))
368         (day-of-week  ((day-of-week M) day-name))
369         (day          (day M))
370         (month-name   (month-name M))
371         (month        ((month M) month-name))
372         (year         (year M))
373         (hour         (hour M))
374         (minute       (minute M))
375         (isecond      (isecond M))
376         (time-of-day  ((time-of-day M) hour minute isecond))
377         (ctime        ((ctime M) between-sp-drop day-of-week month day time-of-day year))
378         (abbrtime     ((abbrtime M) between-sp-drop day-of-week day year month))
379         (address      (address M))
380         (mbox-message-fields (mbox-message-fields M))
381         (mbox-envelope ((mbox-envelope M) address ctime abbrtime))
382         (mbox-message ((mbox-message II) 
383                        mbox-envelope mbox-message-fields ))
384         (mbox-file->messages  ((mbox-file->messages II)
385                                mbox-message))
386         )
387
388    (make-<Mbox> M mbox-envelope mbox-message-fields 
389                 mbox-message mbox-file->messages )
390    ))
391
392
393)
Note: See TracBrowser for help on using the repository browser.