imap: vocab for handling imap
Björn Lindqvist
parent
669eb2482c
commit
e05c1214bd
|
|
@ -0,0 +1,185 @@
|
|||
USING: accessors arrays assocs calendar calendar.format combinators
|
||||
continuations formatting fry grouping.extras imap io.streams.duplex kernel
|
||||
math math.parser math.ranges math.statistics namespaces pcre random sequences
|
||||
sets sorting strings tools.test ;
|
||||
IN: imap.tests
|
||||
|
||||
! Set these to your email account.
|
||||
SYMBOLS: email host password ;
|
||||
|
||||
: random-ascii ( n -- str )
|
||||
[ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
|
||||
|
||||
: make-mail ( from -- mail )
|
||||
now timestamp>rfc822 swap 10000 random
|
||||
3array {
|
||||
"Date: %s"
|
||||
"From: %s"
|
||||
"Subject: afternoon meeting"
|
||||
"To: mooch@owatagu.siam.edu"
|
||||
"Message-Id: <%08d@Blurdybloop.COM>"
|
||||
"MIME-Version: 1.0"
|
||||
"Content-Type: TEXT/PLAIN; CHARSET=US-ASCII"
|
||||
""
|
||||
"Hello Joe, do you think we can meet at 3:30 tomorrow?"
|
||||
} "\r\n" join vsprintf ;
|
||||
|
||||
: sample-mail ( -- mail )
|
||||
"Fred Foobar <foobar@Blurdybloop.COM>" make-mail ;
|
||||
|
||||
! Fails unless you have set the settings.
|
||||
: imap-login ( -- imap4 )
|
||||
host get <imap4ssl> dup [
|
||||
email get password get login drop
|
||||
] with-stream* ;
|
||||
|
||||
: imap-test ( result quot -- )
|
||||
'[ imap-login _ with-stream ] unit-test ; inline
|
||||
|
||||
[ t ] [
|
||||
host get <imap4ssl> duplex-stream?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
host get <imap4ssl> [ capabilities ] with-stream
|
||||
{ "IMAP4rev1" "UNSELECT" "IDLE" "NAMESPACE" "QUOTA" } swap subset?
|
||||
] unit-test
|
||||
|
||||
[ "NO" ] [
|
||||
[ host get <imap4ssl> [ "dont@exist.com" "foo" login ] with-stream ]
|
||||
[ ind>> ] recover
|
||||
] unit-test
|
||||
|
||||
[ "BAD" ] [
|
||||
[ host get <imap4ssl> [ f f login ] with-stream ] [ ind>> ] recover
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
host get <imap4ssl> [
|
||||
email get password get login
|
||||
] with-stream empty?
|
||||
] unit-test
|
||||
|
||||
! Newly created and then selected folder is empty.
|
||||
[ 0 { } ] [
|
||||
10 random-ascii
|
||||
[ create-folder ]
|
||||
[ select-folder ]
|
||||
[ delete-folder ] tri
|
||||
"ALL" "" search-mails
|
||||
] imap-test
|
||||
|
||||
! Create delete select again.
|
||||
[ 0 ] [
|
||||
"örjan" [ create-folder ] [ select-folder ] [ delete-folder ] tri
|
||||
] imap-test
|
||||
|
||||
! Test list folders
|
||||
[ t ] [
|
||||
10 random-ascii
|
||||
[ create-folder "*" list-folders length 0 > ] [ delete-folder ] bi
|
||||
] imap-test
|
||||
|
||||
! Generate some mails for searching
|
||||
[ t t f f ] [
|
||||
10 random-ascii {
|
||||
[ create-folder ]
|
||||
[
|
||||
'[ _ "(\\Seen)" now sample-mail append-mail drop ]
|
||||
10 swap times
|
||||
]
|
||||
[
|
||||
select-folder drop
|
||||
"ALL" "" search-mails
|
||||
5 sample "(RFC822)" fetch-mails
|
||||
[ [ string? ] all? ] [ length 5 = ] bi
|
||||
"SUBJECT" "afternoon" search-mails empty?
|
||||
"(SINCE \"01-Jan-2014\")" "" search-mails empty?
|
||||
]
|
||||
[ delete-folder ]
|
||||
} cleave
|
||||
] imap-test
|
||||
|
||||
! Stat folder
|
||||
[ t ] [
|
||||
10 random-ascii {
|
||||
[ create-folder ]
|
||||
[
|
||||
'[ _ "(\\Seen)" now sample-mail append-mail drop ]
|
||||
10 swap times
|
||||
]
|
||||
[
|
||||
{ "MESSAGES" "UNSEEN" } status-folder
|
||||
[ "MESSAGES" of 0 > ] [ "UNSEEN" of 0 >= ] bi and
|
||||
]
|
||||
[ delete-folder ]
|
||||
} cleave
|
||||
] imap-test
|
||||
|
||||
! Rename folder
|
||||
[ ] [
|
||||
"日本語" [ create-folder ] [
|
||||
"ascii-name" [ rename-folder ] [ delete-folder ] bi
|
||||
] bi
|
||||
] imap-test
|
||||
|
||||
! Create a folder hierarchy
|
||||
[ t ] [
|
||||
"*" list-folders length
|
||||
"foo/bar/baz/日本語" [
|
||||
create-folder "*" list-folders length 4 - =
|
||||
] [ delete-folder ] bi
|
||||
] imap-test
|
||||
|
||||
! A gmail compliant way of creating a folder hierarchy.
|
||||
[ ] [
|
||||
"foo/bar/baz/boo" "/" split { } [ suffix ] cum-map [ "/" join ] map
|
||||
[ [ create-folder ] each ] [ [ delete-folder ] each ] bi
|
||||
] imap-test
|
||||
|
||||
[ ] [
|
||||
"örjan" {
|
||||
[ create-folder ]
|
||||
[ select-folder drop ]
|
||||
! Append mail with a seen flag
|
||||
[ "(\\Seen)" now sample-mail append-mail drop ]
|
||||
! And one without
|
||||
[ "" now sample-mail append-mail drop ]
|
||||
[ delete-folder ]
|
||||
} cleave
|
||||
] imap-test
|
||||
|
||||
! Exercise store-mail
|
||||
[ 5 ] [
|
||||
"INBOX" select-folder drop "ALL" "" search-mails
|
||||
5 sample "+FLAGS" "(\\Recent)" store-mail length
|
||||
] imap-test
|
||||
|
||||
! Internal date parsing
|
||||
[ "Mon, 19 Aug 2013 23:16:36 GMT" ] [
|
||||
"19-Aug-2013 23:16:36 +0000" internal-date>timestamp timestamp>rfc822
|
||||
] unit-test
|
||||
|
||||
[ "19-Aug-2014 23:16:36 GMT" ] [
|
||||
"Mon, 19 Aug 2014 23:16:36 GMT" rfc822>timestamp timestamp>internal-date
|
||||
] unit-test
|
||||
|
||||
! Test parsing an INTERNALDATE from a real mail.
|
||||
[ t ] [
|
||||
"INBOX" select-folder drop
|
||||
"ALL" "" search-mails
|
||||
"(INTERNALDATE)" fetch-mails first
|
||||
"\"([^\"]+)\"" findall first second last
|
||||
internal-date>timestamp timestamp?
|
||||
] imap-test
|
||||
|
||||
! Just an interesting verb to gmail thread mails. Wonder if you can
|
||||
! avoid the double fetch-mails?
|
||||
: threaded-mailbox ( uids -- threads )
|
||||
[
|
||||
"(X-GM-THRID)" fetch-mails [
|
||||
"\\d+" findall [ first last string>number
|
||||
] map
|
||||
] map
|
||||
] [ "(BODY[HEADER.FIELDS (SUBJECT)])" fetch-mails ] bi zip
|
||||
[ first first ] [ sort-with ] [ group-by ] bi ;
|
||||
|
|
@ -0,0 +1,166 @@
|
|||
USING: accessors arrays assocs calendar calendar.format calendar.format.macros
|
||||
formatting fry grouping io io.crlf io.encodings.ascii io.encodings.binary
|
||||
io.encodings.string io.encodings.utf7 io.encodings.utf8 io.sockets
|
||||
io.sockets.secure io.streams.duplex io.streams.string kernel math math.parser
|
||||
sequences splitting strings ;
|
||||
QUALIFIED: pcre
|
||||
IN: imap
|
||||
|
||||
ERROR: imap4-error ind data ;
|
||||
|
||||
CONSTANT: IMAP4_PORT 143
|
||||
CONSTANT: IMAP4_SSL_PORT 993
|
||||
|
||||
! Converts a timestamp to the format imap4 expects.
|
||||
: timestamp>internal-date ( timestamp -- str )
|
||||
[
|
||||
|
||||
{
|
||||
DD "-" MONTH "-" YYYY " "
|
||||
hh ":" mm ":" ss " "
|
||||
[ gmt-offset>> write-gmt-offset ]
|
||||
} formatted
|
||||
] with-string-writer ;
|
||||
|
||||
: internal-date>timestamp ( str -- timestamp )
|
||||
[
|
||||
! Date, month, year.
|
||||
"-" read-token checked-number
|
||||
"-" read-token month-abbreviations index 1 +
|
||||
read-sp checked-number -rot swap
|
||||
! Hour, minute second and gmt offset.
|
||||
read-hms " " expect readln parse-rfc822-gmt-offset <timestamp>
|
||||
] with-string-reader ;
|
||||
|
||||
: >utf7imap4 ( str -- str' )
|
||||
utf7imap4 encode >string ;
|
||||
|
||||
: comma-list ( numbers -- str )
|
||||
[ number>string ] map "," join ;
|
||||
|
||||
: check-status ( ind data -- )
|
||||
over "OK" = not [ imap4-error ] [ 2drop ] if ;
|
||||
|
||||
: read-response-chunk ( stop-expr -- item ? )
|
||||
read-?crlf ascii decode swap dupd pcre:findall
|
||||
[
|
||||
dup "^.*{(\\d+)}$" pcre:findall
|
||||
[
|
||||
dup "^\\* (\\d+) [A-Z-]+ (.*)$" pcre:findall
|
||||
[ ] [ nip first third second ] if-empty
|
||||
]
|
||||
[
|
||||
! Literal item to read, such as message body.
|
||||
nip first second second string>number read ascii decode
|
||||
read-?crlf drop
|
||||
] if-empty t
|
||||
]
|
||||
[ nip first 1 tail values f ] if-empty ;
|
||||
|
||||
: read-response ( tag -- lines )
|
||||
"^%s (BAD|NO|OK) (.*)$" sprintf
|
||||
'[ _ read-response-chunk [ suffix ] dip ] { } swap loop
|
||||
unclip-last first2 [ check-status ] keep suffix ;
|
||||
|
||||
: write-command ( command literal tag -- )
|
||||
-rot [
|
||||
[ "%s %s\r\n" sprintf ] [ length "%s %s {%d}\r\n" sprintf ] if-empty
|
||||
ascii encode write flush
|
||||
] keep [
|
||||
read-?crlf drop "\r\n" append write flush
|
||||
] unless-empty ;
|
||||
|
||||
: command-response ( command literal -- obj )
|
||||
"ABCD" [ write-command ] [ read-response ] bi ;
|
||||
|
||||
! Special parsing
|
||||
: parse-items ( seq -- items )
|
||||
first " " split 2 tail ;
|
||||
|
||||
: parse-list-folders ( str -- folder )
|
||||
"\\* LIST \\(([^\\)]+)\\) \"([^\"]+)\" \"([^\"]+)\"" pcre:findall
|
||||
first 1 tail values [ utf7imap4 decode ] map ;
|
||||
|
||||
: parse-select-folder ( seq -- count )
|
||||
[ "\\* (\\d+) EXISTS" pcre:findall ] map harvest
|
||||
[ f ] [ first first last last string>number ] if-empty ;
|
||||
|
||||
! Returns uid if the server supports the UIDPLUS extension.
|
||||
: parse-append-mail ( seq -- uid/f )
|
||||
[ "\\[APPENDUID (\\d+) \\d+\\]" pcre:findall ] map harvest
|
||||
[ f ] [ first first last last string>number ] if-empty ;
|
||||
|
||||
: parse-status ( seq -- assoc )
|
||||
first "\\* STATUS \"[^\"]+\" \\(([^\\)]+)\\)" pcre:findall first last last
|
||||
" " split 2 group [ string>number ] assoc-map ;
|
||||
|
||||
: parse-store-mail ( seq -- assoc )
|
||||
but-last [
|
||||
"\\(FLAGS \\(([^\\)]+)\\) UID (\\d+)\\)" pcre:findall
|
||||
first 1 tail values first2 [ " " split ] dip string>number swap 2array
|
||||
] map ;
|
||||
|
||||
! Constructor
|
||||
: <imap4ssl> ( host -- imap4 )
|
||||
IMAP4_SSL_PORT <inet> <secure> binary <client> drop
|
||||
! Read the useless welcome message.
|
||||
dup [ "\\*" read-response drop ] with-stream* ;
|
||||
|
||||
! IMAP commands
|
||||
: capabilities ( -- caps )
|
||||
"CAPABILITY" "" command-response parse-items ;
|
||||
|
||||
: login ( user pass -- caps )
|
||||
"LOGIN %s \"%s\"" sprintf "" command-response parse-items ;
|
||||
|
||||
! Folder management
|
||||
: list-folders ( directory -- folders )
|
||||
"LIST \"%s\" *" sprintf "" command-response
|
||||
but-last [ parse-list-folders ] map ;
|
||||
|
||||
: select-folder ( mailbox -- count )
|
||||
>utf7imap4 "SELECT \"%s\"" sprintf "" command-response
|
||||
parse-select-folder ;
|
||||
|
||||
: create-folder ( mailbox -- )
|
||||
>utf7imap4 "CREATE \"%s\"" sprintf "" command-response
|
||||
drop ;
|
||||
|
||||
: delete-folder ( mailbox -- )
|
||||
>utf7imap4 "DELETE \"%s\"" sprintf "" command-response
|
||||
drop ;
|
||||
|
||||
: rename-folder ( old-name new-name -- )
|
||||
[ >utf7imap4 ] bi@ "RENAME \"%s\" \"%s\"" sprintf "" command-response
|
||||
drop ;
|
||||
|
||||
: status-folder ( mailbox keys -- assoc )
|
||||
[ >utf7imap4 ] dip " " join "STATUS \"%s\" (%s)" sprintf
|
||||
"" command-response parse-status ;
|
||||
|
||||
: close-folder ( -- )
|
||||
"CLOSE" "" command-response drop ;
|
||||
|
||||
! Mail management
|
||||
: search-mails ( data-spec str -- uids )
|
||||
[ "UID SEARCH CHARSET UTF-8 %s" sprintf ] dip utf8 encode
|
||||
command-response parse-items [ string>number ] map ;
|
||||
|
||||
: fetch-mails ( message-set data-spec -- texts )
|
||||
[ comma-list ] dip "UID FETCH %s %s" sprintf "" command-response but-last ;
|
||||
|
||||
: copy-mails ( message-set mailbox -- )
|
||||
[ comma-list ] dip >utf7imap4 "UID COPY %s \"%s\"" sprintf ""
|
||||
command-response drop ;
|
||||
|
||||
: append-mail ( mailbox flags date-time mail -- uid/f )
|
||||
[
|
||||
[ >utf7imap4 ]
|
||||
[ [ "" ] [ " " append ] if-empty ]
|
||||
[ timestamp>internal-date ] tri*
|
||||
"APPEND \"%s\" %s\"%s\"" sprintf
|
||||
] dip utf8 encode command-response parse-append-mail ;
|
||||
|
||||
: store-mail ( message-set command flags -- mail-flags )
|
||||
[ comma-list ] 2dip "UID STORE %s %s %s" sprintf "" command-response
|
||||
parse-store-mail ;
|
||||
Loading…
Reference in New Issue