/extra/pop3/pop3.factor

  1! Copyright (C) 2009 Elie Chaftari.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors annotations arrays assocs calendar combinators
  4fry hashtables io io.crlf io.encodings.utf8 io.sockets
  5io.streams.duplex io.timeouts kernel make math math.parser
  6math.ranges namespaces prettyprint sequences splitting
  7strings ;
  8IN: pop3
  9
 10TUPLE: pop3-account
 11# host port timeout user pwd stream capa count list
 12uidls messages ;
 13
 14: <pop3-account> ( -- pop3-account )
 15    pop3-account new
 16        110 >>port
 17        1 minutes >>timeout ;
 18
 19: account ( -- pop3-account ) pop3-account get ;
 20
 21TUPLE: message # uidl headers from to subject size ;
 22
 23<PRIVATE
 24
 25: stream ( -- duplex-stream ) account stream>> ;
 26
 27: <message> ( -- message ) message new ; inline
 28
 29TUPLE: raw-source top headers content ;
 30
 31: <raw-source> ( -- raw-source ) raw-source new ; inline
 32
 33: raw ( -- raw-source ) raw-source get ;
 34
 35: set-read-timeout ( -- )
 36    stream [
 37        account timeout>> timeouts
 38    ] with-stream* ;
 39
 40: get-ok ( -- )
 41    stream [
 42        readln dup "+OK" head? [ drop ] [ throw ] if
 43    ] with-stream* ;
 44
 45: get-ok-and-total ( -- total )
 46    stream [
 47        readln dup "+OK" head? [
 48            " " split second string>number dup account count<<
 49        ] [ throw ] if
 50    ] with-stream* ;
 51
 52: get-ok-and-uidl ( -- uidl )
 53    stream [
 54        readln dup "+OK" head? [
 55            " " split last
 56        ] [ throw ] if
 57    ] with-stream* ;
 58
 59: command ( string -- ) write crlf flush get-ok ;
 60
 61: command-and-total ( string -- total ) write crlf flush
 62    get-ok-and-total ;
 63
 64: command-and-uidl ( string -- uidl ) write crlf flush
 65    get-ok-and-uidl ;
 66
 67: associate-split ( seq -- assoc )
 68    [ " " split1 ] H{ } map>assoc ;
 69
 70: split-map ( seq -- assoc )
 71    associate-split [ [ string>number ] dip ] assoc-map ;
 72
 73: (readlns) ( -- )
 74    readln dup "." = [ , ] dip [ (readlns) ] unless ;
 75
 76: readlns ( -- seq ) [ (readlns) ] { } make but-last ;
 77
 78: (list) ( -- )
 79    stream [
 80        "LIST" command
 81        readlns account list<<
 82    ] with-stream* ;
 83
 84: (uidls) ( -- )
 85    stream [
 86        "UIDL" command
 87        readlns account uidls<<
 88    ] with-stream* ;
 89
 90PRIVATE>
 91
 92: >user ( name -- )
 93    [ stream ] dip '[
 94        "USER " _ append command
 95    ] with-stream* ;
 96
 97: >pwd ( password -- )
 98    [ stream ] dip '[
 99        "PASS " _ append command
100    ] with-stream* ;
101
102: connect ( pop3-account -- )
103    [
104        [ host>> ] [ port>> ] bi
105        <inet> utf8 <client> drop
106    ] keep swap >>stream
107    {
108        [ pop3-account set ]
109        [ user>> [ >user ] when* ]
110        [ pwd>> [ >pwd ] when* ]
111    } cleave
112    set-read-timeout
113    get-ok ;
114
115: capa ( -- array )
116    stream [
117        "CAPA" command
118        readlns dup account capa<<
119    ] with-stream* ;
120
121: count ( -- n )
122    stream [
123        "STAT" command-and-total
124    ] with-stream* ;
125
126: list ( -- assoc )
127    (list) account list>> split-map ;
128
129: uidl ( message# -- uidl )
130    [ stream ] dip '[
131        "UIDL " _ number>string append command-and-uidl
132    ] with-stream* ;
133
134: uidls ( -- assoc )
135    (uidls) account uidls>> split-map ;
136
137: top ( message# #lines -- seq )
138    <raw-source> raw-source set
139    [ stream ] 2dip '[
140        "TOP " _ number>string append " "
141        append _ number>string append
142        command
143        readlns dup raw top<<
144    ] with-stream* ;
145
146: headers ( -- assoc )
147    raw top>> {
148        [
149            [ dup "From:" head?
150                [ raw [ swap suffix ] change-headers drop ]
151                [ drop ] if
152            ] each
153        ]
154        [
155            [ dup "To:" head?
156                [ raw [ swap suffix ] change-headers drop ]
157                [ drop ] if
158            ] each
159        ]
160        [
161            [ dup "Subject:" head?
162                [ raw [ swap suffix ] change-headers drop ]
163                [ drop ] if
164            ] each
165        ]
166    } cleave raw headers>> associate-split ;
167
168: retrieve ( message# -- seq )
169    [ stream ] dip '[
170        "RETR " _ number>string append command
171        readlns dup raw content<<
172    ] with-stream* ;
173
174: delete ( message# -- )
175    [ stream ] dip '[
176        "DELE " _ number>string append command
177    ] with-stream* ;
178
179: reset ( -- )
180    stream [ "RSET" command ] with-stream* ;
181
182: consolidate ( -- seq )
183    count zero? [ "No mail for account." ] [
184        1 account count>> [a,b] [
185            {
186                [ 0 top drop ]
187                [ <message> swap >># ]
188                [ uidls at >>uidl ]
189                [ list at >>size ]
190            } cleave
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>>
196    ] if ;
197
198: close ( -- )
199    stream [ "QUIT" command ] with-stream ;