extra/pop3/pop3.factor

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