/extra/pop3/pop3.factor

http://github.com/abeaumont/factor · Factor · 199 lines · 158 code · 39 blank · 2 comment · 11 complexity · e8de5fad30784649926a1dd5e7ddf280 MD5 · raw file

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