500 lines
15 KiB
Factor
500 lines
15 KiB
Factor
USING: kernel peg.parsers sequences sequences.parser make strings qw sequences.deep calendar calendar.english calendar.parser math math.parser math.order accessors combinators peg unicode parser arrays combinators.short-circuit splitting assocs vocabs.parser words slots.syntax quotations regexp documents.private ;
|
|
USING: prettyprint ;
|
|
|
|
IN: mail.parser
|
|
|
|
TUPLE: mailbox-field display-name local domain ;
|
|
|
|
TUPLE: received-field tokens date-time ;
|
|
|
|
TUPLE: content-type sub-type parameters ;
|
|
|
|
TUPLE: content-type/text < content-type ;
|
|
TUPLE: content-type/image < content-type ;
|
|
TUPLE: content-type/video < content-type ;
|
|
TUPLE: content-type/audio < content-type ;
|
|
TUPLE: content-type/application < content-type ;
|
|
TUPLE: content-type/multipart < content-type ;
|
|
TUPLE: content-type/unknown < content-type ;
|
|
|
|
TUPLE: mail-header
|
|
mime-version content-type
|
|
bcc cc comments date from in-reply-to keywords
|
|
message-id references reply-to sender subject to
|
|
{ optional-fields initial: { } } ;
|
|
|
|
TUPLE: multipart-header
|
|
content-type content-transfer-encoding content-id content-disposition ;
|
|
|
|
TUPLE: multipart header message ;
|
|
|
|
TUPLE: mail { header mail-header } body ;
|
|
|
|
! Core rules
|
|
|
|
: wsp-parser ( -- parser )
|
|
" " token "\t" token 2choice ;
|
|
|
|
: crlf-parser ( -- parser )
|
|
"\r\n" token hide ;
|
|
|
|
: special? ( ch -- ? )
|
|
"()<>[]:;@\\,.\"" member? ;
|
|
|
|
: except ( quot -- parser )
|
|
[ not ] compose satisfy [ 1string ] action ; inline
|
|
|
|
: except-these ( quots -- parser )
|
|
[ 1|| ] curry except ; inline
|
|
|
|
: digit-parser ( -- parser )
|
|
"0-9" range-pattern [ 1string ] action ;
|
|
|
|
: digit-parser2 ( -- parser )
|
|
digit-parser 2 exactly-n ;
|
|
|
|
: digit-parser4 ( -- parser )
|
|
digit-parser 4 exactly-n ;
|
|
|
|
: vchar-parser ( -- parser )
|
|
CHAR: \x20 CHAR: \x7e range [ 1string ] action ;
|
|
|
|
: quoted-pair ( -- parser )
|
|
CHAR: \ 1token vchar-parser wsp-parser 2choice 2seq ;
|
|
|
|
! Folding White Space and Comments
|
|
|
|
: ctext-parser ( -- parser )
|
|
{ [ control? ] [ "()" member? ] } except-these ;
|
|
|
|
: foldable-wsp-parser ( -- parser )
|
|
wsp-parser repeat0 crlf-parser 2seq optional
|
|
wsp-parser repeat1 2seq ;
|
|
|
|
: comment-parser ( -- parser )
|
|
ctext-parser [ comment-parser ] delay 2choice repeat0 "(" ")" surrounded-by hide ;
|
|
|
|
: comment-foldable-wsp-parser ( -- parser )
|
|
foldable-wsp-parser optional
|
|
comment-parser 2seq repeat1 foldable-wsp-parser optional 2seq
|
|
foldable-wsp-parser 2choice ;
|
|
|
|
! Atom
|
|
|
|
: atext-parser ( -- parser )
|
|
"a-zA-Z0-9!#$%&'*+-/=?^_`{}|~" range-pattern [ 1string ] action ;
|
|
|
|
: atom-parser ( -- parser )
|
|
comment-foldable-wsp-parser optional hide
|
|
atext-parser repeat1
|
|
comment-foldable-wsp-parser optional hide 3seq [ flatten "" concat-as ] action ;
|
|
|
|
: dot-atom-parser ( -- parser )
|
|
atom-parser "." token atom-parser 2seq repeat0 optional 2seq sp [ flatten "" concat-as ] action ;
|
|
|
|
! Quoted Strings
|
|
|
|
: quoted-string-parser ( -- parser )
|
|
string-parser ;
|
|
|
|
! Miscellaneous Tokens
|
|
|
|
: word-parser ( -- parser )
|
|
atom-parser quoted-string-parser 2choice ;
|
|
|
|
: phrase-parser ( -- parser )
|
|
word-parser repeat1 [ "" concat-as ] action ;
|
|
|
|
: unstructured-parser ( -- parser )
|
|
foldable-wsp-parser optional vchar-parser 2seq repeat0 wsp-parser repeat0 2seq
|
|
[ flatten "" concat-as ] action sp ;
|
|
|
|
! Date and Time Specification
|
|
|
|
: date-time-zone-parser ( -- parser )
|
|
foldable-wsp-parser hide "+" token "-" token 2choice digit-parser4 3seq
|
|
[ flatten "" concat-as parse-rfc822-gmt-offset ] action ;
|
|
|
|
: date-time-second-parser ( -- parser )
|
|
digit-parser2 [ "" concat-as string>number ] action
|
|
[ 0 60 between? ] semantic ;
|
|
|
|
: date-time-hour-parser ( -- parser )
|
|
digit-parser2 [ "" concat-as string>number ] action
|
|
[ 0 23 between? ] semantic ;
|
|
|
|
: date-time-minute-parser ( -- parser )
|
|
digit-parser2 [ "" concat-as string>number ] action
|
|
[ 0 59 between? ] semantic ;
|
|
|
|
: time-of-day-parser ( -- parser )
|
|
date-time-hour-parser ":" token hide
|
|
date-time-minute-parser ":" token hide
|
|
date-time-second-parser 2seq optional
|
|
[ [ first ] [ 0 ] if* ] action
|
|
4seq ;
|
|
|
|
: date-time-time-parser ( -- parser )
|
|
time-of-day-parser date-time-zone-parser 2seq ;
|
|
|
|
: date-time-year-parser ( -- parser )
|
|
foldable-wsp-parser hide
|
|
digit-parser 4 at-least-n
|
|
foldable-wsp-parser hide 3seq
|
|
[ flatten "" concat-as string>number ] action
|
|
[ 1900 >= ] semantic ;
|
|
|
|
: date-time-month-parser ( -- parse )
|
|
qw{ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec } [ token ] map choice
|
|
[ month-abbreviations index 1 + ] action ;
|
|
|
|
: date-time-day-parser ( -- parser )
|
|
foldable-wsp-parser optional hide
|
|
digit-parser 1 2 from-m-to-n
|
|
foldable-wsp-parser hide 3seq
|
|
[ flatten "" concat-as string>number ] action ;
|
|
|
|
: date-time-date-parser ( -- parser )
|
|
date-time-day-parser
|
|
date-time-month-parser
|
|
date-time-year-parser 3seq ;
|
|
|
|
: date-time-day-name-parser ( -- parser )
|
|
qw{ Mon Tue Wed Thu Fri Sat Sun } [ token ] map choice ;
|
|
|
|
: date-time-day-of-week-parser ( -- parser )
|
|
foldable-wsp-parser optional
|
|
date-time-day-name-parser 2seq ;
|
|
|
|
: date-time-parser ( -- parser )
|
|
date-time-day-of-week-parser "," token 2seq optional hide
|
|
date-time-date-parser
|
|
date-time-time-parser
|
|
comment-foldable-wsp-parser optional hide 4seq
|
|
[
|
|
flatten
|
|
[ timestamp new ] dip
|
|
[ ] each
|
|
{
|
|
[ >>day ] [ >>month ] [ >>year ]
|
|
[ >>hour ] [ >>minute ] [ >>second ]
|
|
[ >>gmt-offset ]
|
|
} spread
|
|
] action ;
|
|
|
|
! Addr-Spec Specification
|
|
|
|
: dtext-parser ( -- parser )
|
|
{ [ " []\\" member? ] [ control? ] } except-these repeat0 ;
|
|
|
|
: domain-literal-parser ( -- parser )
|
|
[
|
|
comment-foldable-wsp-parser optional ,
|
|
foldable-wsp-parser optional
|
|
dtext-parser 2seq
|
|
foldable-wsp-parser optional 2seq
|
|
"[" "]" surrounded-by ,
|
|
comment-foldable-wsp-parser optional ,
|
|
] seq* [ flatten "" concat-as ] action ;
|
|
|
|
: domain-parser ( -- parser )
|
|
dot-atom-parser domain-literal-parser 2choice ;
|
|
|
|
: local-part-parser ( -- parser )
|
|
dot-atom-parser quoted-string-parser 2choice ;
|
|
|
|
: addr-spec-parser ( -- parser )
|
|
local-part-parser "@" token hide domain-parser 3seq
|
|
[ f swap [ ] each mailbox-field boa ] action ;
|
|
|
|
! Address Specification
|
|
|
|
: display-name-parser ( -- parser )
|
|
phrase-parser ;
|
|
|
|
: angle-addr ( -- parser )
|
|
comment-foldable-wsp-parser optional hide
|
|
addr-spec-parser "<" ">" surrounded-by
|
|
comment-foldable-wsp-parser optional hide 3seq [ first ] action ;
|
|
|
|
: name-addr-parser ( -- parser )
|
|
display-name-parser optional angle-addr 2seq [ [ ] each swap >>display-name ] action ;
|
|
|
|
: mailbox-parser ( -- parser )
|
|
name-addr-parser addr-spec-parser 2choice ;
|
|
|
|
: mailbox-list-parser ( -- parser )
|
|
mailbox-parser "," token list-of [ >array ] action ;
|
|
|
|
DEFER: group-parser
|
|
|
|
: address-parser ( -- parser )
|
|
mailbox-parser group-parser 2choice [ ] action ;
|
|
|
|
: group-list-parser ( -- parser )
|
|
mailbox-list-parser comment-foldable-wsp-parser 2choice ;
|
|
|
|
: group-parser ( -- parser )
|
|
[
|
|
display-name-parser ,
|
|
":" token ,
|
|
group-list-parser optional ,
|
|
";" token ,
|
|
comment-foldable-wsp-parser optional hide ,
|
|
] seq* ;
|
|
|
|
: address-list-parser ( -- parser )
|
|
address-parser "," token list-of [ >array ] action ;
|
|
|
|
! Optional Fields
|
|
|
|
: ftext ( -- parser )
|
|
CHAR: \x21 CHAR: \x39 range
|
|
CHAR: \x3b CHAR: \x7e range
|
|
2choice [ 1string ] action ;
|
|
|
|
: known-field-name-parser ( str -- parser )
|
|
[ ftext repeat1 [ "" concat-as >lower ] action ] dip [ = ] curry semantic ;
|
|
|
|
: field-name-parser ( -- parser )
|
|
ftext repeat1 [ "" concat-as >lower ] action ;
|
|
|
|
: field-parser ( -- parser )
|
|
[
|
|
field-name-parser ,
|
|
":" token ,
|
|
unstructured-parser ,
|
|
crlf-parser ,
|
|
] seq* ;
|
|
|
|
: known-field-parser ( str parser -- parser )
|
|
[
|
|
known-field-name-parser
|
|
":" token hide
|
|
] dip
|
|
crlf-parser 4seq [ >array ] action ;
|
|
|
|
: no-fold-literal ( -- parser )
|
|
dtext-parser repeat0 "[" "]" surrounded-by ;
|
|
|
|
: id-left-parser ( -- parser )
|
|
dot-atom-parser ;
|
|
|
|
: id-right-parser ( -- parser )
|
|
dot-atom-parser no-fold-literal 2choice ;
|
|
|
|
: msg-id-parser ( -- parser )
|
|
comment-foldable-wsp-parser optional hide
|
|
id-left-parser "@" token id-right-parser 3seq [ "" concat-as ] action
|
|
"<" ">" surrounded-by
|
|
comment-foldable-wsp-parser optional hide 3seq [ first ] action ;
|
|
|
|
! The origination Date Field
|
|
|
|
: orig-date-parser ( -- parser )
|
|
"date" date-time-parser known-field-parser ;
|
|
|
|
! Originator fields
|
|
|
|
: from-parser ( -- parser )
|
|
"from" mailbox-list-parser known-field-parser ;
|
|
: sender-parser ( -- parser )
|
|
"sender" mailbox-parser known-field-parser ;
|
|
: reply-to-parser ( -- parser )
|
|
"reply-to" address-list-parser known-field-parser ;
|
|
|
|
! Destination Address fields
|
|
|
|
: to-parser ( -- parser )
|
|
"to" address-list-parser known-field-parser ;
|
|
: cc-parser ( -- parser )
|
|
"cc" address-list-parser known-field-parser ;
|
|
: bcc-parser ( -- parser )
|
|
"bcc" address-list-parser known-field-parser ;
|
|
|
|
: message-id-parser ( -- parser )
|
|
"message-id" msg-id-parser known-field-parser ;
|
|
|
|
: in-reply-to-parser ( -- parser )
|
|
"in-reply-to" msg-id-parser repeat1 [ >array ] action known-field-parser ;
|
|
|
|
: references-parser ( -- parser )
|
|
"references" msg-id-parser repeat1 [ >array ] action known-field-parser ;
|
|
|
|
: subject-parser ( -- parser )
|
|
"subject" unstructured-parser known-field-parser ;
|
|
|
|
: comments-parser ( -- parser )
|
|
"comments" unstructured-parser known-field-parser ;
|
|
|
|
: keywords-parser ( -- parser )
|
|
"keywords" phrase-parser sp "," token list-of [ >array ] action known-field-parser ;
|
|
|
|
! Resent Fields
|
|
|
|
: resent-date-parser ( -- parser )
|
|
"resent-date" date-time-parser known-field-parser ;
|
|
|
|
: resent-from-parser ( -- parser )
|
|
"resent-from" mailbox-list-parser known-field-parser ;
|
|
|
|
: resent-sender-parser ( -- parser )
|
|
"resent-sender" mailbox-parser known-field-parser ;
|
|
|
|
: resent-to-parser ( -- parser )
|
|
"resent-to" address-list-parser known-field-parser ;
|
|
|
|
: resent-cc-parser ( -- parser )
|
|
"resent-cc" address-list-parser known-field-parser ;
|
|
|
|
: resent-bcc-parser ( -- parser )
|
|
"resent-bcc" address-list-parser known-field-parser ;
|
|
|
|
: resent-message-id-parser ( -- parser )
|
|
"resent-message-id" msg-id-parser known-field-parser ;
|
|
|
|
! Trace Fields
|
|
|
|
: received-token-parser ( -- parser )
|
|
angle-addr addr-spec-parser domain-parser word-parser 4choice ;
|
|
|
|
: path-parser ( -- parser )
|
|
angle-addr comment-foldable-wsp-parser "<" ">" surrounded-by 2choice ;
|
|
|
|
: return-path-parser ( -- parser )
|
|
"return-path" path-parser known-field-parser ;
|
|
|
|
: received-parser ( -- parser )
|
|
"received"
|
|
received-token-parser repeat0 [ >array ] action
|
|
";" token hide
|
|
date-time-parser 3seq
|
|
[ [ ] each received-field boa ] action
|
|
known-field-parser ;
|
|
|
|
: trace-parser ( -- parser )
|
|
return-path-parser optional
|
|
received-parser repeat1 2seq [ flatten >array ] action ;
|
|
|
|
! Content-Type Field
|
|
|
|
: trim-quotes ( str -- str' )
|
|
[ CHAR: \" = ] trim ;
|
|
: trim-blanks ( str -- str' )
|
|
[ blank? ] trim ;
|
|
|
|
: parse-content-type ( str -- mime-type )
|
|
[
|
|
[ "/" take-until-sequence* >lower ]
|
|
[ ";" take-until-sequence* >lower ]
|
|
[ take-rest ";" split [ "=" split1 [ trim-blanks trim-quotes ] bi@ ] H{ } map>assoc ] tri rot
|
|
] parse-sequence >lower
|
|
{
|
|
{ "text" [ content-type/text boa ] }
|
|
{ "image" [ content-type/image boa ] }
|
|
{ "audio" [ content-type/audio boa ] }
|
|
{ "video" [ content-type/video boa ] }
|
|
{ "application" [ content-type/application boa ] }
|
|
{ "multipart" [ content-type/multipart boa ] }
|
|
{ "unknown" [ content-type/unknown boa ] }
|
|
[ drop content-type/unknown boa ]
|
|
} case ;
|
|
|
|
: content-type-parser ( -- parser )
|
|
"content-type" unstructured-parser [ parse-content-type ] action known-field-parser ;
|
|
|
|
: parse-content-disposition ( str -- content-disposition )
|
|
";" split [ "=" split1 [ trim-blanks trim-quotes ] bi@ ] H{ } map>assoc ;
|
|
|
|
: optional-field-parser ( -- parser )
|
|
field-name-parser ":" token hide unstructured-parser crlf-parser 4seq [ >array ] action ;
|
|
|
|
: known-multipart-field-parser ( str parser -- parser )
|
|
[
|
|
known-field-name-parser
|
|
":" token hide
|
|
] dip
|
|
3seq [ >array ] action ;
|
|
|
|
: multipart-header-field-parser ( -- parser )
|
|
"content-type" unstructured-parser [ parse-content-type ] action known-multipart-field-parser
|
|
"content-disposition" unstructured-parser [ parse-content-disposition ] action known-multipart-field-parser
|
|
"content-id" unstructured-parser known-multipart-field-parser
|
|
"content-transfer-encoding" unstructured-parser known-multipart-field-parser
|
|
4choice ;
|
|
|
|
PEG: parse-multipart-field-header ( str -- header ) multipart-header-field-parser ;
|
|
|
|
: parse-multipart-beginning ( str boundary -- str' )
|
|
[ <sequence-parser> ] dip
|
|
[ take-sequence drop ] curry
|
|
[ take-rest ] bi ;
|
|
|
|
: parse-multipart-header ( str -- header str' )
|
|
[
|
|
[
|
|
"\r\n\r\n" take-until-sequence*
|
|
[
|
|
string-lines
|
|
multipart-header new
|
|
[
|
|
parse-multipart-field-header
|
|
[ second ] [ first ] bi >>writer-word
|
|
1quotation call( multipart-header value -- multipart-header )
|
|
] reduce
|
|
]
|
|
[ f ] if*
|
|
]
|
|
[ take-rest ] bi
|
|
] parse-sequence ;
|
|
|
|
|
|
: parse-multipart ( str separator -- seq )
|
|
"--" prepend "-?-?\r\n" append dup <regexp> [ parse-multipart-beginning ] dip re-split
|
|
[
|
|
[ from>> ] [ to>> ] [ seq>> ] tri subseq
|
|
parse-multipart-header [ multipart boa ] when*
|
|
] map sift ;
|
|
|
|
: fields-parser ( -- seq )
|
|
[
|
|
trace-parser ,
|
|
resent-date-parser ,
|
|
resent-from-parser ,
|
|
resent-sender-parser ,
|
|
resent-to-parser ,
|
|
resent-cc-parser ,
|
|
resent-bcc-parser ,
|
|
resent-message-id-parser ,
|
|
orig-date-parser ,
|
|
from-parser ,
|
|
sender-parser ,
|
|
reply-to-parser ,
|
|
to-parser ,
|
|
cc-parser ,
|
|
bcc-parser ,
|
|
message-id-parser ,
|
|
in-reply-to-parser ,
|
|
references-parser ,
|
|
subject-parser ,
|
|
comments-parser ,
|
|
keywords-parser ,
|
|
content-type-parser ,
|
|
optional-field-parser ,
|
|
] choice* repeat0
|
|
[
|
|
mail-header new
|
|
[
|
|
[ second ] [ first ] bi dup >>writer-word
|
|
[ swap drop 1quotation call( mail-header value -- mail-header ) ]
|
|
[
|
|
[ dup optional-fields>> ] 2dip
|
|
swap 2array 1array append >>optional-fields
|
|
] if*
|
|
] reduce
|
|
] action ;
|
|
|
|
PEG: parse-mail ( str -- mail )
|
|
fields-parser crlf-parser 2seq
|
|
[ first input-slice [ seq>> ] [ from>> ] bi tail mail boa ] action ;
|