extra/imap/imap.factor

   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 ;
   8 QUALIFIED: pcre
   9 IN: imap
  10
  11 ERROR: imap4-error ind data ;
  12
  13 CONSTANT: IMAP4_PORT     143
  14 CONSTANT: IMAP4_SSL_PORT 993
  15
  16 ! Converts a timestamp to the format imap4 expects.
  17 : timestamp>internal-date ( timestamp -- str )
  18     [
  19
  20         {
  21             DD "-" MONTH "-" YYYY " "
  22             hh ":" mm ":" ss " "
  23             [ gmt-offset>> write-gmt-offset ]
  24         } formatted
  25     ] with-string-writer ;
  26
  27 : internal-date>timestamp ( str -- timestamp )
  28     [
  29         ! Date, month, year.
  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  ;
  36
  37 <PRIVATE
  38
  39 : >utf7imap4 ( str -- str' )
  40     utf7imap4 encode >string ;
  41
  42 : comma-list ( numbers -- str )
  43     [ number>string ] map "," join ;
  44
  45 : check-status ( ind data -- )
  46     over "OK" = not [ imap4-error ] [ 2drop ] if ;
  47
  48 : read-response-chunk ( stop-expr -- item ? )
  49     read-?crlf ascii decode swap dupd pcre:findall
  50     [
  51         dup [[ ^.*{(\d+)}$]] pcre:findall
  52         [
  53             dup [[ ^\* (\d+) [A-Z-]+ (.*)$]] pcre:findall
  54             [ ] [ nip first third second ] if-empty
  55         ]
  56         [
  57             ! Literal item to read, such as message body.
  58             nip first second second string>number read ascii decode
  59             read-?crlf drop
  60         ] if-empty t
  61     ]
  62     [ nip first rest values f ] if-empty ;
  63
  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 ;
  68
  69 : write-command ( command literal tag -- )
  70     -rot [
  71         [ "%s %s\r\n" sprintf ] [ length "%s %s {%d}\r\n" sprintf ] if-empty
  72         ascii encode write flush
  73     ] keep [
  74         read-?crlf drop "\r\n" append write flush
  75     ] unless-empty ;
  76
  77 : command-response ( command literal -- obj )
  78     "ABCD" [ write-command ] [ read-response ] bi ;
  79
  80 ! Special parsing
  81 : parse-items ( seq -- items )
  82     first " " split 2 tail ;
  83
  84 : parse-list-folders ( str -- folder )
  85     [[ \* LIST \(([^\)]+)\) "([^"]+)" "?([^"]+)"?]] pcre:findall
  86     first rest values [ utf7imap4 decode ] map ;
  87
  88 : parse-select-folder ( seq -- count )
  89     [ [[ \* (\d+) EXISTS]] pcre:findall ] map harvest
  90     [ f ] [ first first last last string>number ] if-empty ;
  91
  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 ;
  96
  97 : parse-status ( seq -- assoc )
  98     first [[ \* STATUS "[^"]+" \(([^\)]+)\)]] pcre:findall first last last
  99     " " split 2 group [ string>number ] assoc-map ;
 100
 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
 104     ] if-empty ;
 105
 106 : parse-store-mail ( seq -- assoc )
 107     but-last [ parse-store-mail-line ] map sift ;
 108
 109 PRIVATE>
 110
 111 ! Constructor
 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* ;
 116
 117 ! IMAP commands
 118 : capabilities ( -- caps )
 119     "CAPABILITY" "" command-response parse-items ;
 120
 121 : login ( username password -- caps )
 122     "LOGIN %s \"%s\"" sprintf "" command-response parse-items ;
 123
 124 ! Folder management
 125 : list-folders ( directory -- folders )
 126     "LIST \"%s\" *" sprintf "" command-response
 127     but-last [ parse-list-folders ] map ;
 128
 129 : list-all-folders ( -- folders ) "" list-folders ;
 130
 131 : select-folder ( mailbox -- count )
 132     >utf7imap4 "SELECT \"%s\"" sprintf "" command-response
 133     parse-select-folder ;
 134
 135 : create-folder ( mailbox -- )
 136     >utf7imap4 "CREATE \"%s\"" sprintf "" command-response
 137     drop ;
 138
 139 : delete-folder ( mailbox -- )
 140     >utf7imap4 "DELETE \"%s\"" sprintf "" command-response
 141     drop ;
 142
 143 : rename-folder ( old-name new-name -- )
 144     [ >utf7imap4 ] bi@ "RENAME \"%s\" \"%s\"" sprintf "" command-response
 145     drop ;
 146
 147 : status-folder ( mailbox keys -- assoc )
 148     [ >utf7imap4 ] dip " " join "STATUS \"%s\" (%s)" sprintf
 149     "" command-response parse-status ;
 150
 151 : close-folder ( -- )
 152     "CLOSE" "" command-response drop ;
 153
 154 ! Mail management
 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 ;
 158
 159 : fetch-mails ( uids data-spec -- texts )
 160     [ comma-list ] dip "UID FETCH %s %s" sprintf "" command-response but-last ;
 161
 162 : copy-mails ( uids mailbox -- )
 163     [ comma-list ] dip >utf7imap4 "UID COPY %s \"%s\"" sprintf ""
 164     command-response drop ;
 165
 166 : append-mail ( mailbox flags date-time mail -- uid/f )
 167     [
 168         [ >utf7imap4 ]
 169         [ [ "" ] [ " " append ] if-empty ]
 170         [ timestamp>internal-date ] tri*
 171         "APPEND \"%s\" %s\"%s\"" sprintf
 172     ] dip utf8 encode command-response parse-append-mail ;
 173
 174 : store-mail ( uids command flags -- mail-flags )
 175     [ comma-list ] 2dip "UID STORE %s %s %s" sprintf
 176     "" command-response
 177     parse-store-mail ;
 178
 179 ! High level API
 180
 181 : with-imap ( host email password quot -- )
 182     [ <imap4ssl> ] 3dip '[ _ _ login drop @ ] with-stream ; inline
 183
 184 TUPLE: imap-settings host email password ;
 185
 186 : <imap-settings> ( host email password -- obj )
 187     imap-settings new
 188         swap >>password
 189         swap >>email
 190         swap >>host ; inline
 191
 192 : with-imap-settings ( imap-settings quot -- )
 193     [ [ host>> ] [ email>> ] [ password>> ] tri ] dip with-imap ; inline