1 USING: accessors arrays assocs calendar calendar.english
2 calendar.format calendar.parser formatting fry grouping io
3 io.crlf io.encodings.ascii io.encodings.binary
4 io.encodings.string io.encodings.utf7 io.encodings.utf8
5 io.sockets io.sockets.secure io.streams.duplex io.streams.string
6 kernel math math.parser multiline pcre sequences
7 sequences.extras strings ;
11 ERROR: imap4-error ind data ;
13 CONSTANT: IMAP4_PORT 143
14 CONSTANT: IMAP4_SSL_PORT 993
16 ! Converts a timestamp to the format imap4 expects.
17 : timestamp>internal-date ( timestamp -- str )
21 DD "-" MONTH "-" YYYY " "
23 [ gmt-offset>> write-gmt-offset ]
25 ] with-string-writer ;
27 : internal-date>timestamp ( str -- timestamp )
30 "-" read-token checked-number
31 "-" read-token month-abbreviations index 1 +
32 read-sp checked-number spin
33 ! Hour, minute second and gmt offset.
34 read-hms " " expect readln parse-rfc822-gmt-offset <timestamp>
35 ] with-string-reader ;
39 : >utf7imap4 ( str -- str' )
40 utf7imap4 encode >string ;
42 : comma-list ( numbers -- str )
43 [ number>string ] map "," join ;
45 : check-status ( ind data -- )
46 over "OK" = not [ imap4-error ] [ 2drop ] if ;
48 : read-response-chunk ( stop-expr -- item ? )
49 read-?crlf ascii decode swap dupd pcre:findall
51 dup [[ ^.*{(\d+)}$]] pcre:findall
53 dup [[ ^\* (\d+) [A-Z-]+ (.*)$]] pcre:findall
54 [ ] [ nip first third second ] if-empty
57 ! Literal item to read, such as message body.
58 nip first second second string>number read ascii decode
62 [ nip first rest values f ] if-empty ;
64 : read-response ( tag -- lines )
65 "^%s (BAD|NO|OK) (.*)$" sprintf
66 '[ _ read-response-chunk ] loop>array*
67 unclip-last first2 [ check-status ] keep suffix ;
69 : write-command ( command literal tag -- )
71 [ "%s %s\r\n" sprintf ] [ length "%s %s {%d}\r\n" sprintf ] if-empty
72 ascii encode write flush
74 read-?crlf drop "\r\n" append write flush
77 : command-response ( command literal -- obj )
78 "ABCD" [ write-command ] [ read-response ] bi ;
81 : parse-items ( seq -- items )
82 first " " split 2 tail ;
84 : parse-list-folders ( str -- folder )
85 [[ \* LIST \(([^\)]+)\) "([^"]+)" "?([^"]+)"?]] pcre:findall
86 first rest values [ utf7imap4 decode ] map ;
88 : parse-select-folder ( seq -- count )
89 [ [[ \* (\d+) EXISTS]] pcre:findall ] map harvest
90 [ f ] [ first first last last string>number ] if-empty ;
92 ! Returns uid if the server supports the UIDPLUS extension.
93 : parse-append-mail ( seq -- uid/f )
94 [ [=[ \[APPENDUID (\d+) \d+\]]=] pcre:findall ] map harvest
95 [ f ] [ first first last last string>number ] if-empty ;
97 : parse-status ( seq -- assoc )
98 first [[ \* STATUS "[^"]+" \(([^\)]+)\)]] pcre:findall first last last
99 " " split 2 group [ string>number ] assoc-map ;
101 : parse-store-mail-line ( str -- pair/f )
102 [[ \(FLAGS \(([^\)]+)\) UID (\d+)\)]] pcre:findall [ f ] [
103 first rest values first2 [ " " split ] dip string>number swap 2array
106 : parse-store-mail ( seq -- assoc )
107 but-last [ parse-store-mail-line ] map sift ;
112 : <imap4ssl> ( host -- imap4 )
113 IMAP4_SSL_PORT <inet> f <secure> binary <client> drop
114 ! Read the useless welcome message.
115 dup [ "\\*" read-response drop ] with-stream* ;
118 : capabilities ( -- caps )
119 "CAPABILITY" "" command-response parse-items ;
121 : login ( username password -- caps )
122 "LOGIN %s \"%s\"" sprintf "" command-response parse-items ;
125 : list-folders ( directory -- folders )
126 "LIST \"%s\" *" sprintf "" command-response
127 but-last [ parse-list-folders ] map ;
129 : list-all-folders ( -- folders ) "" list-folders ;
131 : select-folder ( mailbox -- count )
132 >utf7imap4 "SELECT \"%s\"" sprintf "" command-response
133 parse-select-folder ;
135 : create-folder ( mailbox -- )
136 >utf7imap4 "CREATE \"%s\"" sprintf "" command-response
139 : delete-folder ( mailbox -- )
140 >utf7imap4 "DELETE \"%s\"" sprintf "" command-response
143 : rename-folder ( old-name new-name -- )
144 [ >utf7imap4 ] bi@ "RENAME \"%s\" \"%s\"" sprintf "" command-response
147 : status-folder ( mailbox keys -- assoc )
148 [ >utf7imap4 ] dip " " join "STATUS \"%s\" (%s)" sprintf
149 "" command-response parse-status ;
151 : close-folder ( -- )
152 "CLOSE" "" command-response drop ;
155 : search-mails ( data-spec str -- uids )
156 [ "UID SEARCH CHARSET UTF-8 %s" sprintf ] dip utf8 encode
157 command-response parse-items [ string>number ] map ;
159 : fetch-mails ( uids data-spec -- texts )
160 [ comma-list ] dip "UID FETCH %s %s" sprintf "" command-response but-last ;
162 : copy-mails ( uids mailbox -- )
163 [ comma-list ] dip >utf7imap4 "UID COPY %s \"%s\"" sprintf ""
164 command-response drop ;
166 : append-mail ( mailbox flags date-time mail -- uid/f )
169 [ [ "" ] [ " " append ] if-empty ]
170 [ timestamp>internal-date ] tri*
171 "APPEND \"%s\" %s\"%s\"" sprintf
172 ] dip utf8 encode command-response parse-append-mail ;
174 : store-mail ( uids command flags -- mail-flags )
175 [ comma-list ] 2dip "UID STORE %s %s %s" sprintf
181 : with-imap ( host email password quot -- )
182 [ <imap4ssl> ] 3dip '[ _ _ login drop @ ] with-stream ; inline
184 TUPLE: imap-settings host email password ;
186 : <imap-settings> ( host email password -- obj )
192 : with-imap-settings ( imap-settings quot -- )
193 [ [ host>> ] [ email>> ] [ password>> ] tri ] dip with-imap ; inline