1 ! Copyright (C) 2009 Elie Chaftari.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors annotations arrays assocs calendar combinators
4 fry hashtables io io.crlf io.encodings.utf8 io.sockets
5 io.streams.duplex io.timeouts kernel make math math.parser
6 math.ranges namespaces prettyprint sequences splitting
11 # host port timeout user pwd stream capa count list
14 : <pop3-account> ( -- pop3-account )
19 : account ( -- pop3-account ) pop3-account get ;
21 TUPLE: message # uidl headers from to subject size ;
25 : stream ( -- duplex-stream ) account stream>> ;
27 : <message> ( -- message ) message new ; inline
29 TUPLE: raw-source top headers content ;
31 : <raw-source> ( -- raw-source ) raw-source new ; inline
33 : raw ( -- raw-source ) raw-source get ;
35 : set-read-timeout ( -- )
37 account timeout>> timeouts
42 readln dup "+OK" head? [ drop ] [ throw ] if
45 : get-ok-and-total ( -- total )
47 readln dup "+OK" head? [
48 " " split second string>number dup account count<<
52 : get-ok-and-uidl ( -- uidl )
54 readln dup "+OK" head? [
59 : command ( string -- ) write crlf flush get-ok ;
61 : command-and-total ( string -- total ) write crlf flush
64 : command-and-uidl ( string -- uidl ) write crlf flush
67 : associate-split ( seq -- assoc )
68 [ " " split1 ] H{ } map>assoc ;
70 : split-map ( seq -- assoc )
71 associate-split [ [ string>number ] dip ] assoc-map ;
74 readln dup "." = [ , ] dip [ (readlns) ] unless ;
76 : readlns ( -- seq ) [ (readlns) ] { } make but-last ;
81 readlns account list<<
87 readlns account uidls<<
94 "USER " _ append command
97 : >pwd ( password -- )
99 "PASS " _ append command
102 : connect ( pop3-account -- )
104 [ host>> ] [ port>> ] bi
105 <inet> utf8 <client> drop
109 [ user>> [ >user ] when* ]
110 [ pwd>> [ >pwd ] when* ]
118 readlns dup account capa<<
123 "STAT" command-and-total
127 (list) account list>> split-map ;
129 : uidl ( message# -- uidl )
131 "UIDL " _ number>string append command-and-uidl
135 (uidls) account uidls>> split-map ;
137 : top ( message# #lines -- seq )
138 <raw-source> raw-source set
140 "TOP " _ number>string append " "
141 append _ number>string append
143 readlns dup raw top<<
146 : headers ( -- assoc )
150 [ raw [ swap suffix ] change-headers drop ]
156 [ raw [ swap suffix ] change-headers drop ]
161 [ dup "Subject:" head?
162 [ raw [ swap suffix ] change-headers drop ]
166 } cleave raw headers>> associate-split ;
168 : retrieve ( message# -- seq )
170 "RETR " _ number>string append command
171 readlns dup raw content<<
174 : delete ( message# -- )
176 "DELE " _ number>string append command
180 stream [ "RSET" command ] with-stream* ;
182 : consolidate ( -- seq )
183 count zero? [ "No mail for account." ] [
184 1 account count>> [a,b] [
187 [ <message> swap >># ]
191 "From:" headers at >>from
192 "To:" headers at >>to
193 "Subject:" headers at >>subject
194 account [ swap suffix ] change-messages drop
195 ] each account messages>>
199 stream [ "QUIT" command ] with-stream ;