extra/pop3/pop3.factor

   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
   7 strings ;
   8 IN: pop3
   9
  10 TUPLE: pop3-account
  11 # host port timeout user pwd stream capa count list
  12 uidls 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
  21 TUPLE: 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
  29 TUPLE: 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-words 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-words 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
  90 PRIVATE>
  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 ;