1 ! Copyright (C) 2009 Elie Chaftari.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs calendar combinators io io.crlf
4 io.encodings.utf8 io.sockets io.streams.duplex io.timeouts
5 kernel make math math.parser namespaces ranges sequences
10 # host port timeout user pwd stream capa count list
13 : <pop3-account> ( -- pop3-account )
18 : account ( -- pop3-account ) pop3-account get ;
20 TUPLE: message # uidl headers from to subject size ;
24 : stream ( -- duplex-stream ) account stream>> ;
26 : <message> ( -- message ) message new ; inline
28 TUPLE: raw-source top headers content ;
30 : <raw-source> ( -- raw-source ) raw-source new ; inline
32 : raw ( -- raw-source ) raw-source get ;
34 : set-read-timeout ( -- )
36 account timeout>> timeouts
41 readln dup "+OK" head? [ drop ] [ throw ] if
44 : get-ok-and-total ( -- total )
46 readln dup "+OK" head? [
47 split-words second string>number dup account count<<
51 : get-ok-and-uidl ( -- uidl )
53 readln dup "+OK" head? [
58 : command ( string -- ) write crlf flush get-ok ;
60 : command-and-total ( string -- total ) write crlf flush
63 : command-and-uidl ( string -- uidl ) write crlf flush
66 : associate-split ( seq -- assoc )
67 [ " " split1 ] H{ } map>assoc ;
69 : split-map ( seq -- assoc )
70 associate-split [ [ string>number ] dip ] assoc-map ;
73 readln dup "." = [ , ] dip [ (readlns) ] unless ;
75 : readlns ( -- seq ) [ (readlns) ] { } make but-last ;
80 readlns account list<<
86 readlns account uidls<<
93 "USER " _ append command
96 : >pwd ( password -- )
98 "PASS " _ append command
101 : connect ( pop3-account -- )
103 [ host>> ] [ port>> ] bi
104 <inet> utf8 <client> drop
108 [ user>> [ >user ] when* ]
109 [ pwd>> [ >pwd ] when* ]
117 readlns dup account capa<<
122 "STAT" command-and-total
126 (list) account list>> split-map ;
128 : uidl ( message# -- uidl )
130 "UIDL " _ number>string append command-and-uidl
134 (uidls) account uidls>> split-map ;
136 : top ( message# #lines -- seq )
137 <raw-source> raw-source set
139 "TOP " _ number>string append " "
140 append _ number>string append
142 readlns dup raw top<<
145 : headers ( -- assoc )
149 [ raw [ swap suffix ] change-headers drop ]
155 [ raw [ swap suffix ] change-headers drop ]
160 [ dup "Subject:" head?
161 [ raw [ swap suffix ] change-headers drop ]
165 } cleave raw headers>> associate-split ;
167 : retrieve ( message# -- seq )
169 "RETR " _ number>string append command
170 readlns dup raw content<<
173 : delete ( message# -- )
175 "DELE " _ number>string append command
179 stream [ "RSET" command ] with-stream* ;
181 : consolidate ( -- seq )
182 count zero? [ "No mail for account." ] [
183 1 account count>> [a..b] [
186 [ <message> swap >># ]
190 "From:" headers at >>from
191 "To:" headers at >>to
192 "Subject:" headers at >>subject
193 account [ swap suffix ] change-messages drop
194 ] each account messages>>
198 stream [ "QUIT" command ] with-stream ;