;;
;;
;; A set of routines to read and extract fields from email form
;; submissions generated by the FormMail.pl script.
;;
;; Copyright 2008-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
;; .
;;
(module formular
(form-delim-start form-delim-end field-delim
form-field form mbox-messages->form-tree)
(import scheme chicken data-structures srfi-1 )
(require-extension typeclass input-classes rb-tree mbox utf8 utf8-srfi-14)
(require-library utf8-srfi-13 abnf abnf-consumers internet-message)
(import (prefix abnf abnf:)
(prefix abnf-consumers abnf:)
(only abnf
Token.CharLex->CoreABNF Input->Token
Token->CharLex
)
(only internet-message )
(only utf8-srfi-13 string-ci< string-ci= string-trim-both)
)
(define consumed-objects-lift-any
(abnf:consumed-objects-lift
(abnf:consumed-objects identity)))
(define (char-list-titlecase x)
(if (null? x) x (cons (char-upcase (car x)) (map char-downcase (cdr x)))))
;; construct symbols from consumed chars
(define consumed-chars->tsymbol
(abnf:consumed-chars->list
(compose string->symbol
list->string
char-list-titlecase
abnf:trim-ws-char-list)))
;; shortcut for (abnf:bind consumed-chars->tsymbol ... )
(define-syntax bind-consumed->tsymbol
(syntax-rules ()
((_ p) (abnf:bind consumed-chars->tsymbol p))
))
(define field-delim (make-parameter #\:))
(define form-delim-start
(make-parameter "---------------------------------------------------------------------------"))
(define form-delim-end
(make-parameter "---------------------------------------------------------------------------"))
(define=> (lwsp ) (set-from-string " \r\n\t"))
(define=> (formpar )
(lambda (p)
(let ((v (p)))
(cond ((char? v) (char v))
((string? v) (lit v))
(else (error 'formpar "parameter must be one of char or string" v))))))
(define=> (field-name )
(bind-consumed->tsymbol (abnf:repetition1 ftext)))
(define=> (field-value )
(abnf:alternatives
quoted-string
unstructured))
(define (form-field lwsp formpar field-name field-value)
(abnf:bind (consumed-objects-lift-any)
(abnf:concatenation
field-name
(abnf:drop-consumed
(abnf:concatenation (formpar field-delim)
(abnf:repetition lwsp)))
field-value
(abnf:drop-consumed (abnf:repetition lwsp)))))
(define (form lwsp formpar form-field)
(abnf:bind-consumed-pairs->list
(abnf:concatenation
(abnf:drop-consumed
(abnf:concatenation
(abnf:repetition lwsp)
(formpar form-delim-start)
(abnf:repetition lwsp)))
(abnf:repetition form-field))))
;;
;; Given a list of messages returned by the file->messages procedure
;; from the mbox library, returns an ordered dictionary structure,
;; where the key is the email address of the form sender, and the
;; value is the list of all forms submitted by that sender. The API of
;; the tree object follows that of the e.g. treap and rb-tree
;; libraries.
;;
(define (lookup-def x lst)
(let ((v (alist-ref x lst)))
(and v (if (pair? (cdr v)) v (car v)))))
(define (mbox-messages->form-tree M)
(define (s<= x y)
(cond ((string-ci< x y) -1)
((string-ci= x y) 0)
(else 1)))
(define (subm< x y)
(let ((x-seconds (lookup-def 'time-seconds (cdr x)))
(y-seconds (lookup-def 'time-seconds (cdr y))))
(< x-seconds y-seconds)))
(let* ((lwsp (lwsp M))
(formpar (formpar M))
(field-name (field-name M))
(field-value (field-value M))
(form-field (form-field lwsp formpar field-name field-value))
(form (form lwsp formpar form-field)))
(lambda (messages)
(let ((m (rb-tree-map s<=)))
(with-instance (( m))
(let loop ((tree (empty)) (msgs messages))
(let ((lookup get) (update put))
(if (null? msgs) tree
(let ((message (car msgs)))
(let ((envelope (message-envelope message))
(headers (message-headers message))
(body (message-body message)))
(let ((time-seconds (lookup-def 'time-seconds envelope))
(from-address (let* ((addresskv (assoc 'address envelope))
(address (and addresskv (cdr addresskv)))
(local-part (lookup-def 'local-part address))
(domain (lookup-def 'domain address)))
(cond ((and local-part domain)
(string-append
(string-trim-both local-part char-set:whitespace)
"@"
(string-trim-both domain char-set:whitespace)))
(local-part
(string-trim-both local-part char-set:whitespace))
(else (error 'mbox-messages->form-tree "invalid address"
address))))))
(let ((exists (lookup tree from-address #f))
(submission `(submission (time-seconds ,time-seconds)
(fields . ,(body mbox-message-body: form)))))
(if exists
(loop (update tree from-address
(merge (list submission) (cdr exists) subm<))
(cdr msgs))
(loop (update tree from-address (list submission)) (cdr msgs)))))))
))))))
))
)