1 USING: accessors arrays assocs calendar calendar.format
2 combinators continuations destructors formatting fry grouping.extras imap
3 imap.private io.streams.duplex kernel math math.parser math.ranges
4 math.statistics namespaces random sequences sets sorting uuid
5 splitting strings system tools.test memoize combinators.smart ;
6 FROM: pcre => findall ;
9 : random-ascii ( n -- str )
10 [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
12 : make-mail ( from -- mail )
13 now timestamp>rfc822 swap 10000 random
17 "Subject: afternoon meeting"
18 "To: mooch@owatagu.siam.edu"
19 "Message-Id: <%08d@Blurdybloop.COM>"
21 "Content-Type: TEXT/PLAIN; CHARSET=US-ASCII"
23 "Hello Joe, do you think we can meet at 3:30 tomorrow?"
24 } "\r\n" join vsprintf ;
26 : sample-mail ( -- mail )
27 "Fred Foobar <foobar@Blurdybloop.COM>" make-mail ;
29 ERROR: no-imap-test-host ;
31 : get-test-host ( -- host )
32 \ imap-settings get-global host>> [ throw-no-imap-test-host ] unless* ;
34 : imap-test ( result quot -- )
35 '[ \ imap-settings get-global _ with-imap-settings ] unit-test ; inline
37 : base-folder ( -- s )
38 os name>> cpu name>> "-" glue ;
40 MEMO: my-uuid ( -- str )
43 : test-folder ( s -- s )
45 base-folder "/" my-uuid "/" _
46 ] "" append-outputs-as ;
49 get-test-host <imap4ssl> [ duplex-stream? ] with-disposal
53 get-test-host <imap4ssl> [ capabilities ] with-stream
54 { "IMAP4rev1" "UNSELECT" "IDLE" "NAMESPACE" "QUOTA" } swap subset?
58 [ get-test-host <imap4ssl> [ "dont@exist.com" "foo" login ] with-stream ]
63 [ get-test-host <imap4ssl> [ f f login ] with-stream ] [ ind>> ] recover
66 ! Try to reset test folder before starting tests
68 [ "foo/bar/baz/日本語" test-folder delete-folder ] ignore-errors
69 [ "foo/bar/baz/boo" test-folder delete-folder ] ignore-errors
70 [ "foo/bar/baz" test-folder delete-folder ] ignore-errors
71 [ "foo/bar" test-folder delete-folder ] ignore-errors
72 [ "foo" test-folder delete-folder ] ignore-errors
73 [ "örjan" test-folder delete-folder ] ignore-errors
74 [ base-folder delete-folder ] ignore-errors
78 { } [ \ imap-settings get-global [ ] with-imap-settings ] unit-test
80 ! Newly created and then selected folder is empty.
89 ! Create delete select again.
92 [ create-folder ] [ select-folder ] [ delete-folder ] tri
98 [ create-folder "*" list-folders length 0 > ] [ delete-folder ] bi
101 ! Generate some mails for searching
106 '[ _ "(\\Seen)" now sample-mail append-mail drop ]
111 "ALL" "" search-mails
112 5 sample "(RFC822)" fetch-mails
113 [ [ string? ] all? ] [ length 5 = ] bi
114 "SUBJECT" "afternoon" search-mails empty?
115 "(SINCE \"01-Jan-2014\")" "" search-mails empty?
126 '[ _ "(\\Seen)" now sample-mail append-mail drop ]
130 { "MESSAGES" "UNSEEN" } status-folder
131 [ "MESSAGES" of 0 > ] [ "UNSEEN" of 0 >= ] bi and
139 "日本語" test-folder [ create-folder ] [
140 "ascii-name" test-folder
141 [ rename-folder ] [ delete-folder ] bi
145 ! Create a folder hierarchy
147 "foo/bar/baz/日本語" test-folder
148 [ '[ _ delete-folder ] ignore-errors ]
150 "*" test-folder list-folders length
152 "*" test-folder list-folders length 4 - =
154 [ delete-folder ] tri
157 ! A gmail compliant way of creating a folder hierarchy.
159 "foo/bar/baz/boo" test-folder "/" split
160 { } [ suffix ] cum-map [ "/" join ] map
161 [ [ create-folder ] each ] [ [ delete-folder ] each ] bi
165 "örjan" test-folder {
167 [ select-folder drop ]
168 ! Append mail with a seen flag
169 [ "(\\Seen)" now sample-mail append-mail drop ]
171 [ "" now sample-mail append-mail drop ]
176 ! Exercise store-mail
178 "INBOX" select-folder drop "ALL" "" search-mails
179 5 sample "+FLAGS" "(\\Recent)" store-mail length
182 ! Internal date parsing
183 { "Mon, 19 Aug 2013 23:16:36 GMT" } [
184 "19-Aug-2013 23:16:36 +0000" internal-date>timestamp timestamp>rfc822
187 { "19-Aug-2014 23:16:36 GMT" } [
188 "Mon, 19 Aug 2014 23:16:36 GMT" rfc822>timestamp timestamp>internal-date
191 ! Test parsing an INTERNALDATE from a real mail.
193 "INBOX" select-folder drop
194 "ALL" "" search-mails
195 "(INTERNALDATE)" fetch-mails first
196 "\"([^\"]+)\"" findall first second last
197 internal-date>timestamp timestamp?
201 { { 8132 { "\\Seen" } } f } [
202 "(FLAGS (\\Seen) UID 8132)" parse-store-mail-line
203 ! Weird non-standard(?) response format gmail uses to indicate the
204 ! previous mail flags. Just ignore it.
205 "(UID 1234 FLAGS (\\Seen))" parse-store-mail-line
208 ! Just an interesting verb to gmail thread mails. Wonder if you can
209 ! avoid the double fetch-mails?
210 : threaded-mailbox ( uids -- threads )
212 "(X-GM-THRID)" fetch-mails [
213 "\\d+" findall [ first last string>number
216 ] [ "(BODY[HEADER.FIELDS (SUBJECT)])" fetch-mails ] bi zip
217 [ first first ] [ sort-with ] [ group-by ] bi ;