imap: Add a word to list all folders and fix a couple issues.

- Fix a bug where the regex assumes double-quotes around a string but Outlook doesn't put them.
- Fix all the \\ escapes in the regexps to look a little better.
- Cleaner looping for reading emails.

! Example query to get some spams
imap-settings get [
  "[Gmail]/Spam" select-folder
  "ALL" "" search-mails 10 head
  "(BODY[1] BODY[HEADER.FIELDS (SUBJECT TO FROM CC BCC)])" fetch-mails
] with-imap-settings
travis-windows
Doug Coleman 2018-11-21 16:58:01 -06:00
parent d82ce045ea
commit f77d46f0c8
2 changed files with 27 additions and 16 deletions

View File

@ -1,8 +1,10 @@
USING: accessors arrays assocs calendar calendar.english calendar.format USING: accessors arrays assocs calendar calendar.english
calendar.parser formatting fry grouping io io.crlf io.encodings.ascii calendar.format calendar.parser formatting fry grouping io
io.encodings.binary io.encodings.string io.encodings.utf7 io.encodings.utf8 io.crlf io.encodings.ascii io.encodings.binary
io.sockets io.sockets.secure io.streams.duplex io.streams.string kernel math io.encodings.string io.encodings.utf7 io.encodings.utf8
math.parser sequences splitting strings ; io.sockets io.sockets.secure io.streams.duplex io.streams.string
kernel math math.parser multiline pcre sequences
sequences.extras strings ;
QUALIFIED: pcre QUALIFIED: pcre
IN: imap IN: imap
@ -46,9 +48,9 @@ CONSTANT: IMAP4_SSL_PORT 993
: read-response-chunk ( stop-expr -- item ? ) : read-response-chunk ( stop-expr -- item ? )
read-?crlf ascii decode swap dupd pcre:findall read-?crlf ascii decode swap dupd pcre:findall
[ [
dup "^.*{(\\d+)}$" pcre:findall dup [[ ^.*{(\d+)}$]] pcre:findall
[ [
dup "^\\* (\\d+) [A-Z-]+ (.*)$" pcre:findall dup [[ ^\* (\d+) [A-Z-]+ (.*)$]] pcre:findall
[ ] [ nip first third second ] if-empty [ ] [ nip first third second ] if-empty
] ]
[ [
@ -61,7 +63,7 @@ CONSTANT: IMAP4_SSL_PORT 993
: read-response ( tag -- lines ) : read-response ( tag -- lines )
"^%s (BAD|NO|OK) (.*)$" sprintf "^%s (BAD|NO|OK) (.*)$" sprintf
'[ _ read-response-chunk [ suffix ] dip ] { } swap loop '[ _ read-response-chunk ] loop>array*
unclip-last first2 [ check-status ] keep suffix ; unclip-last first2 [ check-status ] keep suffix ;
: write-command ( command literal tag -- ) : write-command ( command literal tag -- )
@ -80,24 +82,24 @@ CONSTANT: IMAP4_SSL_PORT 993
first " " split 2 tail ; first " " split 2 tail ;
: parse-list-folders ( str -- folder ) : parse-list-folders ( str -- folder )
"\\* LIST \\(([^\\)]+)\\) \"([^\"]+)\" \"([^\"]+)\"" pcre:findall [[ \* LIST \(([^\)]+)\) "([^"]+)" "?([^"]+)"?]] pcre:findall
first rest values [ utf7imap4 decode ] map ; first rest values [ utf7imap4 decode ] map ;
: parse-select-folder ( seq -- count ) : parse-select-folder ( seq -- count )
[ "\\* (\\d+) EXISTS" pcre:findall ] map harvest [ [[ \* (\d+) EXISTS]] pcre:findall ] map harvest
[ f ] [ first first last last string>number ] if-empty ; [ f ] [ first first last last string>number ] if-empty ;
! Returns uid if the server supports the UIDPLUS extension. ! Returns uid if the server supports the UIDPLUS extension.
: parse-append-mail ( seq -- uid/f ) : parse-append-mail ( seq -- uid/f )
[ "\\[APPENDUID (\\d+) \\d+\\]" pcre:findall ] map harvest [ [=[ \[APPENDUID (\d+) \d+\]]=] pcre:findall ] map harvest
[ f ] [ first first last last string>number ] if-empty ; [ f ] [ first first last last string>number ] if-empty ;
: parse-status ( seq -- assoc ) : parse-status ( seq -- assoc )
first "\\* STATUS \"[^\"]+\" \\(([^\\)]+)\\)" pcre:findall first last last first [[ \* STATUS "[^"]+" \(([^\)]+)\)]] pcre:findall first last last
" " split 2 group [ string>number ] assoc-map ; " " split 2 group [ string>number ] assoc-map ;
: parse-store-mail-line ( str -- pair/f ) : parse-store-mail-line ( str -- pair/f )
"\\(FLAGS \\(([^\\)]+)\\) UID (\\d+)\\)" pcre:findall [ f ] [ [[ \(FLAGS \(([^\)]+)\) UID (\d+)\)]] pcre:findall [ f ] [
first rest values first2 [ " " split ] dip string>number swap 2array first rest values first2 [ " " split ] dip string>number swap 2array
] if-empty ; ] if-empty ;
@ -124,6 +126,8 @@ PRIVATE>
"LIST \"%s\" *" sprintf "" command-response "LIST \"%s\" *" sprintf "" command-response
but-last [ parse-list-folders ] map ; but-last [ parse-list-folders ] map ;
: list-all-folders ( -- folders ) "" list-folders ;
: select-folder ( mailbox -- count ) : select-folder ( mailbox -- count )
>utf7imap4 "SELECT \"%s\"" sprintf "" command-response >utf7imap4 "SELECT \"%s\"" sprintf "" command-response
parse-select-folder ; parse-select-folder ;
@ -168,7 +172,8 @@ PRIVATE>
] dip utf8 encode command-response parse-append-mail ; ] dip utf8 encode command-response parse-append-mail ;
: store-mail ( uids command flags -- mail-flags ) : store-mail ( uids command flags -- mail-flags )
[ comma-list ] 2dip "UID STORE %s %s %s" sprintf "" command-response [ comma-list ] 2dip "UID STORE %s %s %s" sprintf
"" command-response
parse-store-mail ; parse-store-mail ;
! High level API ! High level API

View File

@ -444,12 +444,18 @@ PRIVATE>
: last? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ last ] dip call ; inline : last? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ last ] dip call ; inline
: nth? ( ... n seq quot: ( ... elt -- ... ? ) -- ... ? ) [ nth ] dip call ; inline : nth? ( ... n seq quot: ( ... elt -- ... ? ) -- ... ? ) [ nth ] dip call ; inline
: loop>sequence ( quot exemplar -- seq ) : loop>sequence ( quot: ( -- obj/f ) exemplar -- seq )
[ '[ [ @ [ [ , ] when* ] keep ] loop ] ] dip make ; inline [ '[ [ @ [ [ , ] when* ] keep ] loop ] ] dip make ; inline
: loop>array ( quot -- seq ) : loop>array ( quot: ( -- obj/f ) -- seq )
{ } loop>sequence ; inline { } loop>sequence ; inline
: loop>sequence* ( quot: ( -- obj ? ) exemplar -- seq )
[ '[ [ @ [ [ , ] when* ] [ ] bi* ] loop ] ] dip make ; inline
: loop>array* ( quot: ( -- obj ? ) -- seq )
{ } loop>sequence* ; inline
<PRIVATE <PRIVATE
: (reverse) ( seq -- newseq ) : (reverse) ( seq -- newseq )