Paste: pop3 vocab

! Copyright (C) 2009 Elie Chaftari.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hashtables io
io.crlf io.encodings.utf8 io.sockets io.streams.duplex kernel
locals math math.parser math.ranges namespaces prettyprint
sequences splitting strings ;
IN: pop3

SYMBOL: capa-list
SYMBOL: emails-total
SYMBOL: emails-list
SYMBOL: uidl-list
SYMBOL: email-top
SYMBOL: email-content

TUPLE: email # uidl from to subject size ;

TUPLE: pop3-account
    { # fixnum }
    { host string }
    { port fixnum initial: 110 }
    { user string }
    { password string }
    { emails array } ;

: <email> ( -- email ) email new ; inline

: <pop3-account> ( -- pop3-account ) pop3-account new ; inline

<PRIVATE

: get-ok ( -- )
    readln dup "+OK" head? [ drop ] [ throw ] if ;

: get-ok-and-total ( -- )
    readln dup "+OK" head? [
        " " split second emails-total set-global
    ] [ throw ] if ;

: initialize-connection ( -- )
    V{ } clone emails-list set-global
    V{ } clone email-top set-global
    V{ } clone email-content set-global
    V{ } clone capa-list set-global
    V{ } clone uidl-list set-global ;

: command ( string -- ) write crlf flush ;

: user ( name -- )
    "USER " prepend command get-ok ;

: pass ( password -- )
    "PASS " prepend command get-ok ;

: collect-until ( collector -- )
    "collector" set
    [ readln dup "." = ] [
        "collector" get [ swap suffix ] change-global
    ] until drop ;

: capa ( -- )
    "CAPA" command get-ok capa-list collect-until ;

: get-capa ( -- seq )
    capa capa-list get-global ;

: stat ( -- )
    "STAT" command get-ok-and-total ;

: list ( -- )
    "LIST" command get-ok emails-list collect-until ;

: uidl ( -- )
    "UIDL" command get-ok uidl-list collect-until ;

: associate-split ( seq -- assoc )
    [ " " split1 2array ] map >hashtable ;

: get-uidl ( -- assoc )
    uidl uidl-list get-global associate-split
    [ swap string>number swap ] assoc-map ;

: top ( email# #lines -- )
    [ number>string "TOP " prepend " " append
    ] dip number>string append
    command get-ok email-top collect-until ;

: retr ( email# -- )
    number>string "RETR " prepend command get-ok
    email-content collect-until ;

: dele ( email# -- )
    number>string "DELE " prepend command get-ok ;

: quit ( -- )
    "QUIT" command get-ok ;

: get-list ( -- assoc )
    emails-list get-global associate-split
    [ swap string>number swap ] assoc-map ;

: get-headers ( -- assoc )
    V{ } clone "email-headers" set
    email-top get-global {
        [
            [ dup "From:" head?
                [ "email-headers" [ swap suffix ] change ]
                [ drop ] if
            ] each 
        ]
        [
            [ dup "To:" head?
                [ "email-headers" [ swap suffix ] change ]
                [ drop ] if
            ] each
        ]
        [
            [ dup "Subject:" head?
                [ "email-headers" [ swap suffix ] change ]
                [ drop ] if
            ] each
        ]
    } cleave "email-headers" get associate-split ;

: get-total ( -- n )
    emails-total get-global string>number ;

: consolidate ( -- seq )
    V{ } clone "emails" set
    1 get-total [a,b] >array [
        { [ 0 top ]
        [ <email> swap >># ]
        [ get-uidl at >>uidl ]
        [ get-list at >>size ] } cleave
        "From:" get-headers at >>from
        "To:" get-headers at >>to
        "Subject:" get-headers at >>subject
        "emails" [ swap suffix ] change
    ] each "emails" get ;

PRIVATE>

: collect ( pop3-account -- seq )
    dup "account" set
    initialize-connection
    [ host>> ] [ port>> ] bi <inet> utf8 [
        get-ok
        "account" get
        [ user>> user ]
        [ password>> pass ] bi
        stat list
        get-total zero? [ "No mail for account." ] [ consolidate ] if
        quit
    ] with-client ;