add mail
commit
50a25c2a28
|
|
@ -0,0 +1,5 @@
|
|||
USING: kernel ;
|
||||
USING: mail.parser ;
|
||||
|
||||
IN: mail
|
||||
|
||||
|
|
@ -0,0 +1,161 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors ascii assocs byte-arrays combinators fry
|
||||
hashtables http http.parsers io io.encodings.binary io.files
|
||||
io.files.temp io.files.unique io.streams.string kernel math
|
||||
quoting sequences splitting namespaces sequences.parser arrays regexp ;
|
||||
USING: prettyprint ;
|
||||
IN: mail.multipart
|
||||
|
||||
CONSTANT: buffer-size 65536
|
||||
CONSTANT: separator-prefix "\r\n--"
|
||||
|
||||
SYMBOL: current-boundary
|
||||
|
||||
TUPLE: multipart
|
||||
end-of-stream?
|
||||
current-separator mime-separator
|
||||
header
|
||||
content-disposition bytes
|
||||
filename temp-file
|
||||
name name-content
|
||||
mime-parts ;
|
||||
|
||||
TUPLE: mime-file headers filename temporary-path ;
|
||||
C: <mime-file> mime-file
|
||||
|
||||
TUPLE: mime-variable headers key value ;
|
||||
C: <mime-variable> mime-variable
|
||||
|
||||
: <multipart> ( mime-separator -- multipart )
|
||||
multipart new
|
||||
swap >>mime-separator
|
||||
{ } clone >>mime-parts ;
|
||||
|
||||
: mime-write ( sequence -- )
|
||||
>byte-array write ;
|
||||
|
||||
: parse-headers ( string -- hashtable )
|
||||
string-lines harvest [ parse-header-line ] map >hashtable ;
|
||||
|
||||
: fill-bytes ( multipart -- multipart )
|
||||
buffer-size read
|
||||
[ '[ _ B{ } append-as ] change-bytes ]
|
||||
[ t >>end-of-stream? ] if* ;
|
||||
|
||||
ERROR: mime-decoding-ran-out-of-bytes ;
|
||||
: dump-until-separator ( multipart -- multipart )
|
||||
[ ] [ current-separator>> ] [ bytes>> ] tri
|
||||
dup [ mime-decoding-ran-out-of-bytes ] unless
|
||||
2dup subseq-start [
|
||||
cut-slice
|
||||
[ mime-write ]
|
||||
[ swap length tail-slice >>bytes ] bi*
|
||||
] [
|
||||
tuck [ length ] bi@ - 1 - cut-slice
|
||||
[ mime-write ]
|
||||
[ >>bytes ] bi* fill-bytes
|
||||
dup end-of-stream?>> [ dump-until-separator ] unless
|
||||
] if* ;
|
||||
|
||||
: dump-string ( multipart separator -- multipart string )
|
||||
>>current-separator
|
||||
[ dump-until-separator ] with-string-writer ;
|
||||
|
||||
: read-header ( multipart -- multipart )
|
||||
dup bytes>> "--\r\n" sequence= [
|
||||
t >>end-of-stream?
|
||||
] [
|
||||
"\r\n\r\n" dump-string parse-headers >>header
|
||||
] if ;
|
||||
|
||||
: empty-name? ( string -- ? )
|
||||
{ "''" "\"\"" "" f } member? ;
|
||||
|
||||
: save-uploaded-file ( multipart -- )
|
||||
dup filename>> empty-name? [
|
||||
drop
|
||||
] [
|
||||
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri <mime-file> ]
|
||||
[ content-disposition>> "name" of unquote ]
|
||||
[ mime-parts>> set-at ] tri
|
||||
] if ;
|
||||
|
||||
: save-mime-part ( multipart -- )
|
||||
dup name>> empty-name? [
|
||||
drop
|
||||
] [
|
||||
[ name-content>> ]
|
||||
[ name>> unquote ]
|
||||
[ mime-parts>> set-at ] tri
|
||||
] if ;
|
||||
|
||||
: dump-mime-file ( multipart filename -- multipart )
|
||||
binary <file-writer> [
|
||||
dup mime-separator>> >>current-separator dump-until-separator
|
||||
] with-output-stream ;
|
||||
|
||||
: dump-file ( multipart -- multipart )
|
||||
[ "factor-" "-upload" unique-file ] with-temp-directory
|
||||
[ >>temp-file ] [ dump-mime-file ] bi ;
|
||||
|
||||
: parse-content-disposition-form-data ( string -- hashtable )
|
||||
";" split
|
||||
[ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
|
||||
|
||||
: lookup-disposition ( multipart string -- multipart value/f )
|
||||
over content-disposition>> at ;
|
||||
|
||||
ERROR: unknown-content-disposition multipart ;
|
||||
|
||||
: parse-form-data ( multipart -- multipart )
|
||||
"filename" lookup-disposition [
|
||||
unquote
|
||||
>>filename
|
||||
[ dump-file ] [ save-uploaded-file ] bi
|
||||
] [
|
||||
"name" lookup-disposition [
|
||||
[ dup mime-separator>> dump-string >>name-content ] dip
|
||||
>>name dup save-mime-part
|
||||
] [
|
||||
unknown-content-disposition
|
||||
] if*
|
||||
] if* ;
|
||||
|
||||
ERROR: no-content-disposition multipart ;
|
||||
|
||||
: process-header ( multipart -- multipart )
|
||||
dup "content-disposition" header ";" split1 swap {
|
||||
{ "form-data" [
|
||||
parse-content-disposition-form-data >>content-disposition
|
||||
parse-form-data
|
||||
] }
|
||||
[ no-content-disposition ]
|
||||
} case ;
|
||||
|
||||
: read-assert-sequence= ( sequence -- )
|
||||
[ length read ] keep assert-sequence= ;
|
||||
|
||||
! : with-boundary ( boundary quote -- )
|
||||
! [] dip
|
||||
! current-boundary swap with-variable ; inline
|
||||
|
||||
: parse-beginning ( str boundary -- str' )
|
||||
[ <sequence-parser> ] dip
|
||||
[ take-sequence drop ] curry
|
||||
[ take-rest ] bi ;
|
||||
|
||||
: parse-header ( str -- header str' )
|
||||
[
|
||||
[
|
||||
"\r\n\r\n" take-until-sequence*
|
||||
string-lines harvest [ parse-header-line
|
||||
parse-content-disposition-form-data ] map >hashtable
|
||||
]
|
||||
[ take-rest ] bi
|
||||
] parse-sequence ;
|
||||
|
||||
: parse-multipart ( str separator -- seq )
|
||||
"--" prepend "\r\n" append dup <regexp> [ parse-beginning ] dip re-split
|
||||
[ [ from>> ] [ to>> ] [ seq>> ] tri subseq parse-header 2array ] map ;
|
||||
|
||||
|
|
@ -0,0 +1,499 @@
|
|||
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 ;
|
||||
Loading…
Reference in New Issue