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

;;
;; 
;;  A parser for mbox database files. 
;;
;;  Based on RFC 4155, "The application/mbox Media Type".
;;
;;  Copyright 2010-2012 Ivan Raikov and the Okinawa Institute of Science
;;  and Technology.
;;
;;  This program is free software: you can redistribute it and/or
;;  modify it under the terms of the GNU General Public License as
;;  published by the Free Software Foundation, either version 3 of the
;;  License, or (at your option) any later version.
;;
;;  This program is distributed in the hope that it will be useful,
;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;  General Public License for more details.
;;
;;  A full copy of the GPL license can be found at
;;  <http://www.gnu.org/licenses/>.

(module mbox

        (
         mbox-file->messages
         message? message-envelope message-headers message-body
         <Mbox> Input+.CoreABNF->Mbox Input+.CoreABNF->Mbox/UTF8
         )

        (import scheme chicken data-structures posix srfi-1 srfi-14)

        (require-extension typeclass input-classes)
        (require-library extras abnf abnf-consumers internet-message  )
                         
        (import (prefix abnf abnf: ) 
                (prefix abnf-consumers abnf: ) 
                (only abnf <CoreABNF> <Token> <CharLex> 
                      CharLex->CoreABNF Input->Token 
                      Token->CharLex 
                      )
                (only internet-message <InetMessage> CoreABNF->InetMessage CoreABNF->InetMessage/UTF8)
                (only extras pp)
                )


(define-record-type message
  (make-message envelope headers body )
  message?
  (envelope     message-envelope )
  (headers      message-headers )
  (body         message-body )
  )



(define-class <Mbox> (<InetMessage> M) 
  mbox-envelope mbox-message-fields
  mbox-message mbox-file->messages )


;; Unix ctime date and time specification

;; Parses a date and time specification of the form
;;
;;   Tue Jan 5 18:29:55 2010

;; Matches the abbreviated weekday names

(define=> (day-name <InetMessage>)
  (abnf:alternatives
   (lit "Mon")
   (lit "Tue")
   (lit "Wed")
   (lit "Thu")
   (lit "Fri")
   (lit "Sat")
   (lit "Sun")))

;; Matches a day-name

(define=> (day-of-week <InetMessage>)
  (lambda (day-name)
    (abnf:bind-consumed-strings->list 
     'day-of-week 
     (abnf:bind-consumed->string day-name))))

;; Matches a four digit decimal number

(define=> (year <InetMessage>)
  (abnf:bind-consumed-strings->list 'year 
  (abnf:bind-consumed->string 
   (abnf:repetition-n 4 decimal))))

;; Matches the abbreviated month names


(define=> (month-name <InetMessage>)
  (abnf:alternatives
   (lit "Jan")
   (lit "Feb")
   (lit "Mar")
   (lit "Apr")
   (lit "May")
   (lit "Jun")
   (lit "Jul")
   (lit "Aug")
   (lit "Sep")
   (lit "Oct")
   (lit "Nov")
   (lit "Dec")))

;; Matches a month-name

(define=> (month <InetMessage>)
  (lambda (month-name)
    (abnf:bind-consumed-strings->list 'month 
      (abnf:bind-consumed->string month-name))))


;; Matches a one or two digit number

(define=> (day <InetMessage>)
  (abnf:bind-consumed-strings->list 'day 
   (abnf:bind-consumed->string 
    (abnf:variable-repetition 1 2 decimal))))

;; Matches a two-digit number 

(define=> (hour <InetMessage>)
  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
(define=> (minute <InetMessage>)
  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
(define=> (isecond <InetMessage>)
  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))

;; Matches a time-of-day specification of hh:mm or hh:mm:ss.

(define=> (time-of-day  <InetMessage>)
  (lambda (hour minute isecond)
    (abnf:bind-consumed-strings->list 'time-of-day 
    (abnf:concatenation
     hour (abnf:drop-consumed (char #\:))
     minute (abnf:optional-sequence 
             (abnf:concatenation 
              (abnf:drop-consumed (char #\:))
              isecond))))))


(define=> (between-sp-drop <InetMessage>)
  (lambda (p)
    (abnf:concatenation
     (abnf:drop-consumed (abnf:repetition1 sp))
     p
     (abnf:drop-consumed (abnf:repetition sp)))))

(define=> (ctime <InetMessage>)
  (lambda (between-sp-drop day-of-week month day time-of-day year)
    (abnf:bind-consumed-pairs->list 'ctime
      (abnf:concatenation
       day-of-week 
       (between-sp-drop month)
       day
       (between-sp-drop time-of-day)
       year))))


(define=> (abbrtime  <InetMessage>)
  (lambda (between-sp-drop day-of-week day year month)
    (abnf:bind-consumed-pairs->list 'abbrtime
      (abnf:concatenation
       day-of-week 
       (between-sp-drop day)
       year
       (between-sp-drop month)))))


(define=> (mbox-message-fields <InetMessage>)
  (fields crlf: lf))

(define=> (address <InetMessage> )
  (abnf:bind-consumed-pairs->list 'address
    (abnf:alternatives 
     addr-spec 
     (abnf:bind-consumed-strings->list 'local-part
      (abnf:concatenation
       (abnf:bind-consumed->string
        (abnf:concatenation
         (abnf:repetition1 ftext)))
       (abnf:drop-consumed 
        (abnf:repetition wsp)))))))
  

(define=> (mbox-envelope <InetMessage>)
  (lambda (address ctime abbrtime)
    (abnf:bind-consumed-pairs->list 'envelope
     (abnf:concatenation
      (abnf:drop-consumed 
       (abnf:concatenation 
        (abnf:optional-sequence (char #\newline))
        (lit "From ")
        ))
      address
      (abnf:alternatives ctime abbrtime)
      (abnf:drop-consumed lf)))))


(define stream-consumed car)
(define stream-rest cdr)


(define (month->number month)
  (case (string->symbol month)
    ((Jan) 0)
    ((Feb) 1)
    ((Mar) 2)
    ((Apr) 3)
    ((May) 4)
    ((Jun) 5)
    ((Jul) 6)
    ((Aug) 7)
    ((Sep) 8)
    ((Oct) 9)
    ((Nov) 10)
    ((Dec) 11)))
  

(define (lookup-def x lst)
  (let ((v (alist-ref x lst)))
    (and v (if (pair? (cdr v)) v (car v)))))

(define (ctime->seconds lst)
  (let ((month (lookup-def 'month lst))
        (day   (lookup-def 'day lst))
        (time-of-day (lookup-def 'time-of-day lst))
        (year (lookup-def 'year lst)))
    (and month day time-of-day year
         (let ((month (month->number month))
               (day   (string->number day))
               (time-of-day (map string->number time-of-day))
               (year (string->number year)))
           (let ((t (list->vector
                    (append time-of-day
                            (list day month (- year 1900)
                                  0 0 #f 0)))))
             
             (local-time->seconds t)
             )))))
                                       
    

(define (abbrtime->seconds lst)
  (let ((month (lookup-def 'month lst))
        (day   (lookup-def 'day lst))
        (year  (lookup-def 'year lst)))
    (and month day year
         (let ((month (month->number month))
               (day   (string->number day))
               (year (string->number year)))
           (local-time->seconds
            (list->vector
             (append (list 0 0 0)
                     (list day month (- year 1900)
                           0 0 #f 0))))))))
                                       
    

(define (make-mbox-envelope x)
  (let ((alst (and (pair? x) (eq? 'envelope (car x)) (cdr x))))
    (and alst
         (let ((ctime (lookup-def 'ctime alst))
               (abbrtime (lookup-def 'abbrtime alst)))
           (let ((time-seconds 
                  (cond (ctime (ctime->seconds ctime))
                        (abbrtime (abbrtime->seconds abbrtime))
                        (else #f))))
             `((time-seconds ,time-seconds) . ,alst))))))


(define=> (mbox-message <Input+> )

  (lambda (mbox-envelope mbox-message-fields )

    (lambda (s)

      (let* ((res (find (string->input-stream "\n\n") s))
             (s1  (mbox-envelope identity error `(() ,(car res))))
             (s2  (cadr res)))

        (and (pair? s1)
             
             (make-message
              
              (make-mbox-envelope (car (stream-consumed s1)))
              
              (lambda () 
                (mbox-message-fields stream-consumed error
                                     `(() ,(car (stream-rest s1)))))
              
              (let ((parts (map (lambda (x) `(() ,(first x))) s2)))
                (lambda (#!key (mbox-message-body (lambda (sk fk s) (sk s))))
                  (concatenate 
                   (filter-map
                    (lambda (part) (mbox-message-body stream-consumed (lambda _ #f) part))
                    parts))))
              
              ))))
  ))


(define=> (mbox-file->messages <Input+>)

  (lambda (mbox-message)

    (lambda (filename)
      
      (let* ((strm    (file->input-stream filename 1048476))
             (res     (find (string->input-stream "\nFrom ") strm)))

        (let ((lst (cons (list (car res)) (cadr res))))

        (filter-map (compose mbox-message car) lst)
        ))
      )))


(define (Input+.CoreABNF->Mbox II A)

  (let* ((M   (CoreABNF->InetMessage A))

         (between-sp-drop  (between-sp-drop M))
         (day-name     (day-name M))
         (day-of-week  ((day-of-week M) day-name))
         (day          (day M))
         (month-name   (month-name M))
         (month        ((month M) month-name))
         (year         (year M))
         (hour         (hour M))
         (minute       (minute M))
         (isecond      (isecond M))
         (time-of-day  ((time-of-day M) hour minute isecond))
         (ctime        ((ctime M) between-sp-drop day-of-week month day time-of-day year))
         (abbrtime     ((abbrtime M) between-sp-drop day-of-week day year month))
         (address      (address M))
         (mbox-message-fields (mbox-message-fields M))
         (mbox-envelope ((mbox-envelope M) address ctime abbrtime))
         (mbox-message ((mbox-message II) 
                        mbox-envelope mbox-message-fields ))
         (mbox-file->messages  ((mbox-file->messages II)
                                mbox-message))
         )

    (make-<Mbox> M mbox-envelope mbox-message-fields 
                 mbox-message mbox-file->messages )
    ))


(define (Input+.CoreABNF->Mbox/UTF8 II A)

  (let* ((M   (CoreABNF->InetMessage/UTF8 A))

         (between-sp-drop  (between-sp-drop M))
         (day-name     (day-name M))
         (day-of-week  ((day-of-week M) day-name))
         (day          (day M))
         (month-name   (month-name M))
         (month        ((month M) month-name))
         (year         (year M))
         (hour         (hour M))
         (minute       (minute M))
         (isecond      (isecond M))
         (time-of-day  ((time-of-day M) hour minute isecond))
         (ctime        ((ctime M) between-sp-drop day-of-week month day time-of-day year))
         (abbrtime     ((abbrtime M) between-sp-drop day-of-week day year month))
         (address      (address M))
         (mbox-message-fields (mbox-message-fields M))
         (mbox-envelope ((mbox-envelope M) address ctime abbrtime))
         (mbox-message ((mbox-message II) 
                        mbox-envelope mbox-message-fields ))
         (mbox-file->messages  ((mbox-file->messages II)
                                mbox-message))
         )

    (make-<Mbox> M mbox-envelope mbox-message-fields 
                 mbox-message mbox-file->messages )
    ))


)