extra/imap/imap.factor

   1 USING: accessors arrays assocs calendar calendar.english
   2 calendar.format calendar.parser formatting grouping io io.crlf
   3 io.encodings.ascii io.encodings.binary io.encodings.string
   4 io.encodings.utf7 io.encodings.utf8 io.sockets io.sockets.secure
   5 io.streams.duplex io.streams.string kernel math math.parser
   6 multiline sequences sequences.extras splitting strings ;
   7 QUALIFIED: pcre
   8 IN: imap
   9
  10 ERROR: imap4-error ind data ;
  11
  12 CONSTANT: IMAP4_PORT     143
  13 CONSTANT: IMAP4_SSL_PORT 993
  14
  15 ! Converts a timestamp to the format imap4 expects.
  16 : timestamp>internal-date ( timestamp -- str )
  17     [
  18
  19         {
  20             DD "-" MONTH "-" YYYY " "
  21             hh ":" mm ":" ss " "
  22             [ gmt-offset>> write-gmt-offset ]
  23         } formatted
  24     ] with-string-writer ;
  25
  26 : internal-date>timestamp ( str -- timestamp )
  27     [
  28         ! Date, month, year.
  29         "-" read-token checked-number
  30         "-" read-token month-abbreviations index 1 +
  31         read-sp checked-number spin
  32         ! Hour, minute second and gmt offset.
  33         read-hms " " expect readln parse-rfc822-gmt-offset <timestamp>
  34     ] with-string-reader  ;
  35
  36 <PRIVATE
  37
  38 : >utf7imap4 ( str -- str' )
  39     utf7imap4 encode >string ;
  40
  41 : comma-list ( numbers -- str )
  42     [ number>string ] map "," join ;
  43
  44 : check-status ( ind data -- )
  45     over "OK" = not [ imap4-error ] [ 2drop ] if ;
  46
  47 : read-response-chunk ( stop-expr -- item ? )
  48     read-?crlf ascii decode swap dupd pcre:findall
  49     [
  50         dup [[ ^.*{(\d+)}$]] pcre:findall
  51         [
  52             dup [[ ^\* (\d+) [A-Z-]+ (.*)$]] pcre:findall
  53             [ ] [ nip first third second ] if-empty
  54         ]
  55         [
  56             ! Literal item to read, such as message body.
  57             nip first second second string>number read ascii decode
  58             read-?crlf drop
  59         ] if-empty t
  60     ]
  61     [ nip first rest values f ] if-empty ;
  62
  63 : read-response ( tag -- lines )
  64     "^%s (BAD|NO|OK) (.*)$" sprintf
  65     '[ _ read-response-chunk ] loop>array*
  66     unclip-last first2 [ check-status ] keep suffix ;
  67
  68 : write-command ( command literal tag -- )
  69     -rot [
  70         [ "%s %s\r\n" sprintf ] [ length "%s %s {%d}\r\n" sprintf ] if-empty
  71         ascii encode write flush
  72     ] keep [
  73         read-?crlf drop "\r\n" append write flush
  74     ] unless-empty ;
  75
  76 : command-response ( command literal -- obj )
  77     "ABCD" [ write-command ] [ read-response ] bi ;
  78
  79 ! Special parsing
  80 : parse-items ( seq -- items )
  81     first split-words 2 tail ;
  82
  83 : parse-list-folders ( str -- folder )
  84     [[ \* LIST \(([^\)]+)\) "([^"]+)" "?([^"]+)"?]] pcre:findall
  85     first rest values [ utf7imap4 decode ] map ;
  86
  87 : parse-select-folder ( seq -- count )
  88     [ [[ \* (\d+) EXISTS]] pcre:findall ] map harvest
  89     [ f ] [ first first last last string>number ] if-empty ;
  90
  91 ! Returns uid if the server supports the UIDPLUS extension.
  92 : parse-append-mail ( seq -- uid/f )
  93     [ [=[ \[APPENDUID (\d+) \d+\]]=] pcre:findall ] map harvest
  94     [ f ] [ first first last last string>number ] if-empty ;
  95
  96 : parse-status ( seq -- assoc )
  97     first [[ \* STATUS "[^"]+" \(([^\)]+)\)]] pcre:findall first last last
  98     split-words 2 group [ string>number ] assoc-map ;
  99
 100 : parse-store-mail-line ( str -- pair/f )
 101     [[ \(FLAGS \(([^\)]+)\) UID (\d+)\)]] pcre:findall [ f ] [
 102         first rest values first2 [ split-words ] dip string>number swap 2array
 103     ] if-empty ;
 104
 105 : parse-store-mail ( seq -- assoc )
 106     but-last [ parse-store-mail-line ] map sift ;
 107
 108 PRIVATE>
 109
 110 ! Constructor
 111 : <imap4ssl> ( host -- imap4 )
 112     IMAP4_SSL_PORT <inet> f <secure> binary <client> drop
 113     ! Read the useless welcome message.
 114     dup [ "\\*" read-response drop ] with-stream* ;
 115
 116 ! IMAP commands
 117 : capabilities ( -- caps )
 118     "CAPABILITY" "" command-response parse-items ;
 119
 120 : login ( username password -- caps )
 121     "LOGIN %s \"%s\"" sprintf "" command-response parse-items ;
 122
 123 ! Folder management
 124 : list-folders ( directory -- folders )
 125     "LIST \"%s\" *" sprintf "" command-response
 126     but-last [ parse-list-folders ] map ;
 127
 128 : list-all-folders ( -- folders ) "" list-folders ;
 129
 130 : select-folder ( mailbox -- count )
 131     >utf7imap4 "SELECT \"%s\"" sprintf "" command-response
 132     parse-select-folder ;
 133
 134 : create-folder ( mailbox -- )
 135     >utf7imap4 "CREATE \"%s\"" sprintf "" command-response
 136     drop ;
 137
 138 : delete-folder ( mailbox -- )
 139     >utf7imap4 "DELETE \"%s\"" sprintf "" command-response
 140     drop ;
 141
 142 : rename-folder ( old-name new-name -- )
 143     [ >utf7imap4 ] bi@ "RENAME \"%s\" \"%s\"" sprintf "" command-response
 144     drop ;
 145
 146 : status-folder ( mailbox keys -- assoc )
 147     [ >utf7imap4 ] dip join-words "STATUS \"%s\" (%s)" sprintf
 148     "" command-response parse-status ;
 149
 150 : close-folder ( -- )
 151     "CLOSE" "" command-response drop ;
 152
 153 ! Mail management
 154 : search-mails ( data-spec str -- uids )
 155     [ "UID SEARCH CHARSET UTF-8 %s" sprintf ] dip utf8 encode
 156     command-response parse-items [ string>number ] map ;
 157
 158 : fetch-mails ( uids data-spec -- texts )
 159     [ comma-list ] dip "UID FETCH %s %s" sprintf "" command-response but-last ;
 160
 161 : copy-mails ( uids mailbox -- )
 162     [ comma-list ] dip >utf7imap4 "UID COPY %s \"%s\"" sprintf ""
 163     command-response drop ;
 164
 165 : append-mail ( mailbox flags date-time mail -- uid/f )
 166     [
 167         [ >utf7imap4 ]
 168         [ [ "" ] [ " " append ] if-empty ]
 169         [ timestamp>internal-date ] tri*
 170         "APPEND \"%s\" %s\"%s\"" sprintf
 171     ] dip utf8 encode command-response parse-append-mail ;
 172
 173 : store-mail ( uids command flags -- mail-flags )
 174     [ comma-list ] 2dip "UID STORE %s %s %s" sprintf
 175     "" command-response
 176     parse-store-mail ;
 177
 178 ! High level API
 179
 180 : with-imap ( host email password quot -- )
 181     [ <imap4ssl> ] 3dip '[ _ _ login drop @ ] with-stream ; inline
 182
 183 TUPLE: imap-settings host email password ;
 184
 185 : <imap-settings> ( host email password -- obj )
 186     imap-settings new
 187         swap >>password
 188         swap >>email
 189         swap >>host ; inline
 190
 191 : with-imap-settings ( imap-settings quot -- )
 192     [ [ host>> ] [ email>> ] [ password>> ] tri ] dip with-imap ; inline