steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Small cleanup

db4
Slava Pestov 2008-03-20 14:25:23 -05:00
parent e20762e0cb
commit c5eae01930
1 changed files with 10 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
extra/smtp/smtp.factor
View File

@ -8,7 +8,7 @@ calendar.format new-slots accessors ;
IN: smtp IN: smtp
SYMBOL: smtp-domain SYMBOL: smtp-domain
SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
SYMBOL: read-timeout 1 minutes read-timeout set-global SYMBOL: read-timeout 1 minutes read-timeout set-global
SYMBOL: esmtp t esmtp set-global SYMBOL: esmtp t esmtp set-global
@ -25,8 +25,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
: crlf "\r\n" write ; : crlf "\r\n" write ;
: command ( string -- ) write crlf flush ;
: helo ( -- ) : helo ( -- )
esmtp get "EHLO " "HELO " ? write host-name write crlf ; esmtp get "EHLO " "HELO " ? host-name append command ;
: validate-address ( string -- string' ) : validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident. #! Make sure we send funky stuff to the server by accident.
@ -34,13 +36,13 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
[ "Bad e-mail address: " prepend throw ] unless ; [ "Bad e-mail address: " prepend throw ] unless ;
: mail-from ( fromaddr -- ) : mail-from ( fromaddr -- )
"MAIL FROM:<" write validate-address write ">" write crlf ; "MAIL FROM:<" swap validate-address ">" 3append command ;
: rcpt-to ( to -- ) : rcpt-to ( to -- )
"RCPT TO:<" write validate-address write ">" write crlf ; "RCPT TO:<" swap validate-address ">" 3append command ;
: data ( -- ) : data ( -- )
"DATA" write crlf ; "DATA" command ;
: validate-message ( msg -- msg' ) : validate-message ( msg -- msg' )
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ; "." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
@ -49,10 +51,10 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
string-lines string-lines
validate-message validate-message
[ write crlf ] each [ write crlf ] each
"." write crlf ; "." command ;
: quit ( -- ) : quit ( -- )
"QUIT" write crlf ; "QUIT" command ;
LOG: smtp-response DEBUG LOG: smtp-response DEBUG
@ -85,7 +87,7 @@ LOG: smtp-response DEBUG
readln readln
dup multiline? [ 3 head process-multiline ] when ; dup multiline? [ 3 head process-multiline ] when ;
: get-ok ( -- ) flush receive-response check-response ; : get-ok ( -- ) receive-response check-response ;
: validate-header ( string -- string' ) : validate-header ( string -- string' )
dup "\r\n" seq-intersect empty? dup "\r\n" seq-intersect empty?