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

Last change on this file since 27583 was 27583, checked in by Ivan Raikov, 8 years ago

mbox: added support for unicode

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