! Copyright (C) 2009 Elie Chaftari. ! See http://factorcode.org/license.txt for BSD license. USING: accessors annotations arrays assocs combinators fry hashtables io io.crlf io.encodings.utf8 io.sockets io.streams.duplex kernel make math math.parser math.ranges namespaces prettyprint sequences splitting strings ; IN: pop3.interactive TUPLE: pop3-account # host port timeout user password stream capa stat list uidls messages ; : ( -- pop3-account ) pop3-account new 110 >>port 60 >>timeout ; : account ( -- pop3-account ) pop3-account get ; : stream ( -- duplex-stream ) account stream>> ; TUPLE: message # uidl headers from to subject size ; : ( -- message ) message new ; inline TUPLE: raw-source top headers content ; : ( -- raw-source ) raw-source new ; inline : raw ( -- raw-source ) raw-source get ; number account swap >>stat drop ] [ throw ] if ] with-stream* ; : command ( string -- ) write crlf flush ; : associate-split ( seq -- assoc ) [ " " split1 2array ] map >hashtable ; : (readlns) ( -- ) readln dup "." = [ , ] dip [ (readlns) ] unless ; : readlns ( -- seq ) [ (readlns) ] { } make but-last ; PRIVATE> : pop3-connection ( pop3-account -- ) [ [ host>> ] [ port>> ] bi utf8 drop ] keep swap >>stream pop3-account set get-ok ; : >user ( name -- ) stream swap '[ "USER " _ append command get-ok ] with-stream* ; : >pass ( password -- ) stream swap '[ "PASS " _ append command get-ok ] with-stream* ; : capa ( -- ) stream [ "CAPA" command get-ok account readlns >>capa drop ] with-stream* ; : stat ( -- ) stream [ "STAT" command get-ok-and-total ] with-stream* ; : (list) ( -- ) stream [ "LIST" command get-ok account readlns >>list drop ] with-stream* ; : list ( -- assoc ) (list) account list>> associate-split [ swap string>number swap ] assoc-map ; : (uidl) ( -- ) stream [ "UIDL" command get-ok account readlns >>uidls drop ] with-stream* ; : uidl ( -- assoc ) (uidl) account uidls>> associate-split [ swap string>number swap ] assoc-map ; : top ( message# #lines -- ) raw-source set stream -rot '[ "TOP " _ number>string append " " append _ number>string append command get-ok raw readlns >>top drop ] with-stream* ; : retr ( message# -- ) stream swap '[ "RETR " _ number>string append command get-ok raw readlns >>content drop ] with-stream* ; : raw-content ( -- seq ) raw content>> ; : dele ( message# -- ) stream swap '[ "DELE " _ number>string append command get-ok ] with-stream* ; : headers ( -- assoc ) raw top>> { [ [ dup "From:" head? [ raw [ swap suffix ] change-headers drop ] [ drop ] if ] each ] [ [ dup "To:" head? [ raw [ swap suffix ] change-headers drop ] [ drop ] if ] each ] [ [ dup "Subject:" head? [ raw [ swap suffix ] change-headers drop ] [ drop ] if ] each ] } cleave raw headers>> associate-split ; : consolidate ( -- seq ) account stat>> zero? [ "No mail for account." ] [ 1 account stat>> [a,b] [ { [ 0 top ] [ swap >># ] [ uidl at >>uidl ] [ list at >>size ] } cleave "From:" headers at >>from "To:" headers at >>to "Subject:" headers at >>subject account [ swap suffix ] change-messages drop ] each account messages>> ] if ; : quit ( -- ) stream [ "QUIT" command get-ok ] with-stream ;