--- /dev/null
+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 ;
--- /dev/null
+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 ;
projects / factor.git / commitdiff