Update actions, because Node.js 16 actions are deprecated, to Node.js 20

[factor.git] / basis / smtp / smtp.factor

diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index 47429b823d8a06f71de463c3b5c6ce23a6c50058..d073176b32665fae245ef3217cde8be9cf1bbe94 100644 (file)
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels,
 ! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
+! See https://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs base64 calendar calendar.format
-classes combinators debugger fry io io.crlf io.encodings
+classes combinators debugger io io.crlf io.encodings
 io.encodings.ascii io.encodings.binary io.encodings.iana
 io.encodings.string io.encodings.utf8 io.sockets
 io.sockets.secure io.timeouts kernel logging make math.order
@@ -17,6 +17,9 @@ SINGLETON: no-auth
 TUPLE: plain-auth username password ;
 C: <plain-auth> plain-auth
 
+TUPLE: login-auth username password ;
+C: <login-auth> login-auth
+
 : <smtp-config> ( -- smtp-config )
     smtp-config new ; inline
 
@@ -67,9 +70,9 @@ TUPLE: email
 ERROR: bad-email-address email ;
 
 : 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.
     dup "\r\n>" intersects?
-    [ throw-bad-email-address ] when ;
+    [ bad-email-address ] when ;
 
 : mail-from ( fromaddr -- )
     validate-address
@@ -129,18 +132,18 @@ ERROR: smtp-transaction-failed < smtp-error ;
 
 : check-response ( response -- )
     dup code>> {
-        { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
-        { [ dup 400 499 between? ] [ drop throw-smtp-server-busy ] }
-        { [ dup 500 = ] [ drop throw-smtp-syntax-error ] }
-        { [ dup 501 = ] [ drop throw-smtp-command-not-implemented ] }
-        { [ dup 500 509 between? ] [ drop throw-smtp-syntax-error ] }
-        { [ dup 530 539 between? ] [ drop throw-smtp-bad-authentication ] }
-        { [ dup 550 = ] [ drop throw-smtp-mailbox-unavailable ] }
-        { [ dup 551 = ] [ drop throw-smtp-user-not-local ] }
-        { [ dup 552 = ] [ drop throw-smtp-exceeded-storage-allocation ] }
-        { [ dup 553 = ] [ drop throw-smtp-bad-mailbox-name ] }
-        { [ dup 554 = ] [ drop throw-smtp-transaction-failed ] }
-        [ drop throw-smtp-error ]
+        { [ dup { 220 235 250 221 334 354 } member? ] [ 2drop ] }
+        { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
+        { [ dup 500 = ] [ drop smtp-syntax-error ] }
+        { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
+        { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
+        { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
+        { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
+        { [ dup 551 = ] [ drop smtp-user-not-local ] }
+        { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
+        { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
+        { [ dup 554 = ] [ drop smtp-transaction-failed ] }
+        [ drop smtp-error ]
     } cond ;
 
 : get-ok ( -- ) receive-response check-response ;
@@ -149,13 +152,21 @@ GENERIC: send-auth ( auth -- )
 
 M: no-auth send-auth drop ;
 
+: >smtp-base64 ( str -- str' )
+    utf8 encode >base64 >string ;
+
 : plain-auth-string ( username password -- string )
-    [ "\0" prepend ] bi@ append utf8 encode >base64 >string ;
+    [ "\0" prepend ] bi@ append >smtp-base64 ;
 
 M: plain-auth send-auth
     [ username>> ] [ password>> ] bi plain-auth-string
     "AUTH PLAIN " prepend command get-ok ;
 
+M: login-auth send-auth
+    "AUTH LOGIN" command get-ok
+    [ username>> >smtp-base64 command get-ok ]
+    [ password>> >smtp-base64 command get-ok ] bi ;
+
 : auth ( -- ) smtp-config get auth>> send-auth ;
 
 : encode-header ( string -- string' )
@@ -168,7 +179,7 @@ ERROR: invalid-header-string string ;
 
 : validate-header ( string -- string' )
     dup "\r\n" intersects?
-    [ throw-invalid-header-string ] when ;
+    [ invalid-header-string ] when ;
 
 : write-header ( key value -- )
     [ validate-header write ]
@@ -182,7 +193,7 @@ ERROR: invalid-header-string string ;
         "<" %
         64 random-bits #
         "-" %
-        gmt timestamp>micros #
+        now timestamp>micros #
         "@" %
         smtp-config get domain>> [ host-name ] unless* %
         ">" %
@@ -214,7 +225,10 @@ ERROR: invalid-header-string string ;
     [
         get-ok
         helo get-ok
-        smtp-config get tls?>> [ start-tls get-ok send-secure-handshake ] when
+        smtp-config get tls?>> [
+            start-tls get-ok send-secure-handshake
+            helo get-ok
+        ] when
         auth
         dup from>> extract-email mail-from get-ok
         dup to>> [ extract-email rcpt-to get-ok ] each