1 USING: accessors arrays assocs calendar calendar.format calendar.parser
2 combinators continuations destructors formatting fry grouping.extras imap
3 imap.private io.streams.duplex kernel math math.parser ranges
4 namespaces random sequences sets sorting uuid multiline
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>> [ 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 ;
52 get-test-host <imap4ssl> [ duplex-stream? ] with-disposal
56 get-test-host <imap4ssl> [ capabilities ] with-stream
57 { "IMAP4rev1" "UNSELECT" "IDLE" "NAMESPACE" "QUOTA" } swap subset?
61 [ get-test-host <imap4ssl> [ "dont@exist.com" "foo" login ] with-stream ]
66 [ get-test-host <imap4ssl> [ f f login ] with-stream ] [ ind>> ] recover
69 ! Try to reset test folder before starting tests
71 [ "foo/bar/baz/日本語" test-folder delete-folder ] ignore-errors
72 [ "foo/bar/baz/boo" test-folder delete-folder ] ignore-errors
73 [ "foo/bar/baz" test-folder delete-folder ] ignore-errors
74 [ "foo/bar" test-folder delete-folder ] ignore-errors
75 [ "foo" test-folder delete-folder ] ignore-errors
76 [ "örjan" test-folder delete-folder ] ignore-errors
77 [ base-folder delete-folder ] ignore-errors
81 { } [ \ imap-settings get-global [ ] with-imap-settings ] unit-test
83 ! Newly created and then selected folder is empty.
92 ! Create delete select again.
95 [ create-folder ] [ select-folder ] [ delete-folder ] tri
101 [ create-folder "*" list-folders length 0 > ] [ delete-folder ] bi
104 ! Generate some mails for searching
109 '[ _ "(\\Seen)" now sample-mail append-mail drop ]
114 "ALL" "" search-mails
115 5 sample "(RFC822)" fetch-mails
116 [ [ string? ] all? ] [ length 5 = ] bi
117 "SUBJECT" "afternoon" search-mails empty?
118 "(SINCE \"01-Jan-2014\")" "" search-mails empty?
129 '[ _ "(\\Seen)" now sample-mail append-mail drop ]
133 { "MESSAGES" "UNSEEN" } status-folder
134 [ "MESSAGES" of 0 > ] [ "UNSEEN" of 0 >= ] bi and
142 "日本語" test-folder [ create-folder ] [
143 "ascii-name" test-folder
144 [ rename-folder ] [ delete-folder ] bi
148 ! Create a folder hierarchy
150 "foo/bar/baz/日本語" test-folder
151 [ '[ _ delete-folder ] ignore-errors ]
153 "*" test-folder list-folders length
155 "*" test-folder list-folders length 4 - =
157 [ delete-folder ] tri
160 ! A gmail compliant way of creating a folder hierarchy.
162 "foo/bar/baz/boo" test-folder "/" split
163 { } [ suffix ] accumulate* [ "/" join ] map
164 [ [ create-folder ] each ] [ [ delete-folder ] each ] bi
168 "örjan" test-folder {
170 [ select-folder drop ]
171 ! Append mail with a seen flag
172 [ "(\\Seen)" now sample-mail append-mail drop ]
174 [ "" now sample-mail append-mail drop ]
179 ! Exercise store-mail
181 "INBOX" select-folder drop "ALL" "" search-mails
182 5 sample "+FLAGS" "(\\Recent)" store-mail length
185 ! Internal date parsing
186 { "Mon, 19 Aug 2013 23:16:36 GMT" } [
187 "19-Aug-2013 23:16:36 +0000" internal-date>timestamp timestamp>rfc822
190 { "19-Aug-2014 23:16:36 GMT" } [
191 "Mon, 19 Aug 2014 23:16:36 GMT" rfc822>timestamp timestamp>internal-date
194 ! Test parsing an INTERNALDATE from a real mail.
196 "INBOX" select-folder drop
197 "ALL" "" search-mails
198 "(INTERNALDATE)" fetch-mails first
199 "\"([^\"]+)\"" findall first second last
200 internal-date>timestamp timestamp?
204 { { 8132 { "\\Seen" } } f } [
205 "(FLAGS (\\Seen) UID 8132)" parse-store-mail-line
206 ! Weird non-standard(?) response format gmail uses to indicate the
207 ! previous mail flags. Just ignore it.
208 "(UID 1234 FLAGS (\\Seen))" parse-store-mail-line
211 ! Just an interesting verb to gmail thread mails. Wonder if you can
212 ! avoid the double fetch-mails?
213 : threaded-mailbox ( uids -- threads )
215 "(X-GM-THRID)" fetch-mails [
216 "\\d+" findall [ first last string>number
219 ] [ "(BODY[HEADER.FIELDS (SUBJECT)])" fetch-mails ] bi zip
220 [ first first ] [ sort-with ] [ group-by ] bi ;