anew --Email--       \ FJR 080628
\
\ 4email-interface.f
\
\ *! 4thEmail-dexh
\ *T Simple Email Access Library
\ *Q Frank Russo - June 2008
\ *P This is intended to be a simple wordset for Email Access in forth.
\ *+
\
\ Vs 2.2 FJR 080628
\ needs wininet.f
\ needs sock.f
\ needs Base64-Encode.f
\
\ * *************************************************************************************
\
110 value pop3-port	\ default value
587 value smtp-port	\ default value
0 value #recs		\ # of messages in the inbox
0 value pop3-socket
0 value smtp-socket
0 value receive-buffer
0 value new-msg-buffer
0 value header-buffer
0 value smtp-buffer
0 value hd-buf-ptr
0 value Msg-Size
0 value op-param
\
create eom     0x0d c, 0x0a c, 0x2e c, 0x0d c, 0x0a c,
create eoh     0x0d c, 0x0a c, 0x0d c, 0x0a c,
create eodata  0x0d c, 0x2e c, 0x0d c,
create ebt s" < EOT >" dup allot ebt swap cmove
create recs$ 16 allot recs$ 16 32 fill s" TOP" recs$ swap cmove
create n>string$ 8 allot n>string$ 8 0 fill
\
\ Create a data structure to hold as much info as is possible
\
0 nostack1
32 char+ field+ pop3-server$
32 char+ field+ smtp-server$
32 char+ field+ user$
32 char+ field+ userpw$
1024 char+ field+ tmp$
1024 char+ field+ tmp1$
constant mem-size
\
\ * *************************************************************************************
\
: activate-bit ( bit# - n+bit ) 1 swap lshift ;
: bit@         ( n bit# - bit ) activate-bit and ;
: bit!  ( n 1/0 bit# - n-bit! )      \ puts a bit ( 1/0 ) in n
   dup activate-bit rot
       if   rot or nip               \ 1 ( 1 1-bit# - 1-bit )
       else drop over swap bit@ dup
            if   -                   \ 3 ( 0 1-bit# - 0-bit )
            else drop                \ 2 ( 0 0-bit# - 0-bit )
            then
       then
;
\
: WriteSocketLine ( adr u s - F )
  dup >r Sock-Write 0= if r> drop exit then
  crlf$ count r> sock-write 0=
;
: test-bit   ( n bit# - true/false ) bit@ 0<>  ;
: init-pop3  ( addr n - s Flag ) pop3-port sock-open ;
: init-smtp  ( addr n - s Flag ) smtp-port sock-open ;
: wPop3 ( adr u - ) pop3-socket WriteSocketLine abort" Can't write to the pop3-server."  ;
: WSmtp ( adr u - ) smtp-socket WriteSocketLine abort" Can't write to the smtp-server."  ;
: "tS   ( adr u - ) smtp-socket Sock-Write      abort" Can't write to the smtp-server."  ;
: read-pop3-socket ( buffer n - n f ) pop3-socket sock-read dup 0= ;
: read-smtp-socket ( buffer n - n f ) smtp-socket sock-read dup 0= ;
: _rP  ( adr size - u ) read-pop3-socket abort" pop3-server did not respond."  ;
: rP   ( adr - adr u )  dup max-dyn-string _rP ;
: rP#  ( adr size -- adr #) _rP ;
: rP?  ( -- # )  pop3-socket sock-read? ;
: rS   ( adr - adr u )  dup maxstring read-smtp-socket abort" smtp-server did not respond." ;
: +ok? ( adr len - Flag )    s" +OK" search nip nip ;
: rP-ok?  ( - Flag ) receive-buffer dup zcount erase rP +ok? ;
: rS?  ( - adr u ) smtp-buffer dup zcount erase rS ;
: transaction-state? ( - flag ) s" NOOP" wPop3  rP-ok? ;
: encryption-key   ( - adr count ) s" 4ePost"  ;
\
\ * *************************************************************************************
\
\ *S Email Library and Initialization Words for Email Connections
\
: encrypt/decrypt$ ( orginal$|encrypted$ count - encrypted$|orginal$ count )
   encryption-key 2 pick  0 locals| key-char cnt max-key |
   -rot 0
       do   i  max-key /mod drop 2 pick  + c@ to key-char  \ key-char
            dup i + c@                                     \ char to encript/decript
            dup i 1+ key-char + 8 /mod drop tuck test-bit not swap bit! \ encript/decript
            i op-param tmp$ + c!                                    \ store it
       loop
    2drop op-param tmp$ cnt
;
\
: n>string ( n a -- )
\ *G Converts numbers to counted string for output to a file \n
\ ** For String to Number use: S" 1234" (NUMBER?) (str len -- N 0 ior)
 >r dup >r abs s>d <# #s r> sign #>
 r@ char+ swap dup >r cmove r> r> c!
;
\
\ * *************************************************************************************
\
: sread ( sock -- addr n flag ) \ FJR 080628
    receive-buffer zcount erase
    100 ms dup sock-read? 0> \ if empty = -1
    if
      receive-buffer max-dyn-string rot sock-read receive-buffer swap -1
    else drop 0
    then
;
\
\ * ************************************************ *************************************
\
: xmit-command ( addr n -- addr n flag ) \ 080608 FJR
           10 _ms wPop3
           pop3-socket sread
;
\
\ * *************************************************************************************
\
: Retrieve-msg ( n - Adr Length )   \ FJR 080703
\ *G  'Retrieve-msg' \n
\ **
 op-param tmp1$ zcount 0 fill
 receive-buffer zcount erase
 new-msg-buffer zcount erase
 dup 1 #recs between
 if
   n>string$ n>string
   S" LIST " new-msg-buffer swap cmove
   S" RETR " op-param tmp1$ swap cmove
   n>string$ count op-param tmp1$ zcount + swap cmove
   n>string$ count new-msg-buffer zcount + swap cmove

   new-msg-buffer zcount WPop3 rP-ok?
   if receive-buffer zcount 3 /string evaluate nip then \ '+OK 1 2575'
   receive-buffer zcount erase

   begin
        100 ms op-param tmp1$ zcount WPop3 100 ms rP-ok?
   until

   begin
    250 ms rP?

    -if
        receive-buffer zcount + swap rP# dup
    else
       receive-buffer zcount nip 2 pick <
       if 0 else -1 then
    then

   until

   2drop
 else drop
 then

 op-param tmp1$ zcount 0 fill
 new-msg-buffer zcount erase
 depth 1 > if drop then
 receive-buffer zcount \ values returned to calling routine
;
\
\ * *************************************************************************************
\
: Delete-msg ( N - Flag )
\ *G  'Delete-msg' \n
\ **
 op-param tmp$ 1024 0 fill
 dup 1 #recs between
 if
   n>string$ n>string
   S" Dele " op-param tmp$ swap cmove
   n>string$ count op-param tmp$ zcount + swap cmove
   op-param tmp$ zcount WPop3 RP-ok?
 else drop 0
 then
;
\
\ * *************************************************************************************
\
: Get-Mail-Stats ( - count size ) \ 080608 FJR
\ *G  'Get-Mail-Stats' \n
\ **
  receive-buffer zcount erase
  begin
   100 ms s" STAT" wPop3 rp-ok?
  until
  receive-buffer zcount
\ process line of input getting the count and total size and leave on stack e.g. '+ok 16 25345 '
   3 /string evaluate
  over to #recs \ save # of msgs available
;
\
\ * *************************************************************************************
\
: Get-Mail-List (  - Addr N ) \ Updated 080518
\ *G  'Get-Mail-List' \n
\ **
    begin
     100 _ms s" LIST" wpop3 rp-ok?
    until
    receive-buffer zcount
    op-param tmp$ zcount 0 fill
    op-param tmp$ swap cmove  \ move received data to the Tmp$
    \ process the text in tmp$ retrieving the # and size
    op-param tmp$ zcount
    crlf$ count search drop swap 2 + swap 2 -
    \ find the size of the largest email message
	over dup zcount 3 - + swap  \ Loop from Adr till Adr + zcount
	do
	  I dup 32 crlf$ count search 2drop
	  over 2dup - evaluate \ e.g. '  1  2345 ' leaving 2 numbers on the stack Msg# and Msg-Size
	  nip Msg-size max to msg-size \ updated 080518
	  swap - 2 +
	+loop
;
\
\ * *************************************************************************************
\
: Get-Msg-Header  (  n -  Addr Count flag ) \ Updated 080628
\ *G  'Get-Msg-Header' \n
\ **
\
  dup 1 #recs between \ check to see if n on stack is between 1 and #recs
  if
    n>string$ n>string \ convert # on stack to a string
    n>string$ dup c@ swap 1+ swap
    recs$ 4 + swap cmove ascii 0 recs$ 8 + c!

     begin
        begin transaction-state? until
        recs$ 16 xmit-command
     until

  else drop 0
  then
;
\
\ * *************************************************************************************
\
: Authorization ( flag userpw-addr n user-addr n - flag)  \ 080101
\ *G  'Authorization' \n
\ **
    receive-buffer zcount erase
    op-param tmp$ zcount 0 fill
    s" USER " op-param tmp$ swap cmove op-param tmp$ zcount + swap cmove    \ ' USER account-name'
    op-param tmp$ zcount wPop3 rP-ok? op-param tmp$ zcount 0 fill

    if
      receive-buffer zcount erase
      op-param tmp$ zcount 0 fill
      s" PASS " op-param tmp$ swap cmove op-param tmp$ zcount + swap cmove  \ ' PASS account-password'
      op-param tmp$ zcount wPop3 rP-ok? op-param tmp$ zcount 0 fill
      not if drop 0 then
    else drop 0
    then
;
\
\ * *************************************************************************************
\
: init-inmail	( addr n addr n addr n - flag )
\ *G  'init-inmail' \n
\ **
   op-param pop3-server$ 32 0 fill
   0 to #recs
   op-param pop3-server$ swap cmove
   op-param user$ swap cmove
   op-param userpw$ swap cmove
   op-param pop3-server$ zcount init-pop3 not \ invert the flag returned
   if
      dup to pop3-socket
      if  rP-ok? drop -1 op-param userpw$ zcount op-param user$ zcount Authorization
      else 0
      then
   else drop 0
   then
;
\
\ * *************************************************************************************
\
: init-outmail	( addr n - flag ) \ Addr = SMTP server FJR080511
\ *G  'init-outmail' \n
\ **
   0 to smtp-buffer
   0 to smtp-socket
   init-smtp not
   if
     to smtp-socket
     max-dyn-string malloc to smtp-buffer
     rS? s" 220" search nip nip
   else 0
   then
;
\
\ * *************************************************************************************
\
: init-connection ( - flag )
\ *G  init-connection. \n
\ **
 inet-check
   if
\ initialize all variables
     0 to header-buffer
     0 to new-msg-buffer
     0 to receive-buffer
     0 to op-param
     mem-size malloc to op-param
     op-param mem-size 0 fill
     max-dyn-string
     dup malloc to receive-buffer
     dup malloc to new-msg-buffer
     malloc to header-buffer
     receive-buffer max-dyn-string 0 fill
     new-msg-buffer max-dyn-string 0 fill
     header-buffer  max-dyn-string 0 fill
     recs$ 16 32 fill s" TOP" recs$ swap cmove
     0 to #recs
   then
 inet-stat
;
\
\ * *************************************************************************************
\
: clear-buffers
  header-buffer  free to header-buffer
  new-msg-buffer free to new-msg-buffer
  receive-buffer free to receive-buffer
  op-param	 free to op-param
;
\
\ * *************************************************************************************
\
: Close-email
  transaction-state? 	  drop 100 _ms
  s" QUIT" WPOP3 rP-ok?   drop 100 _ms
  pop3-socket sock-close  drop 100 _ms
  clear-buffers
;
\
\ * *************************************************************************************
\
: Email-Avail ( addr len addr len -- ) \ Updated 080511 FJR
\ *G 'Email-Avail' Check to see if a connection to Email server is possible \n
inet-check \ Internet connection available?
if
   pop3-avail not
   if \ pop3 port not in use at moment
    init-pop3
    not to pop3-avail \ save status
    100 _ms sock-close drop
   else 2drop
   then
   smtp-avail not
   if
    init-smtp
    not to smtp-avail
    100 _ms sock-close drop
   else 2drop
   then
else 4drop 0 to pop3-avail 0 to smtp-avail
then
;
\
\ * ********************************************************************************
\
: SMTP ( buffer-addr -- F ) \ Updated 080511 FJR
\
\ *G  'SMTP' Connects to ISP and sends out email. \n
\
 3 0 do
       ai-ftp smtp-addr zcount
       init-outmail
       if leave then
     loop

smtp-socket
 if
  smtp-buffer zcount 0 fill
  s" ehlo " smtp-buffer swap cmove
  ai-ftp sessionID zcount smtp-buffer zcount + swap cmove
  smtp-buffer zcount    WSmtp rs? 2drop
  s" auth login"        WSmtp rs? 2drop
  ai-ftp email-user     zcount Encode-a-Line
  WSmtp rs? 2drop
  ai-ftp email-password zcount Encode-a-Line
  WSmtp rs? 2drop
  \
  \ Process the buffer
  \ mail from:
  \ rcpt to:
  \ data
  \
  s" QUIT" WSmtp rs? 2drop
  smtp-buffer free to smtp-buffer
  smtp-socket closesocket to smtp-socket
  -1
 else 2drop 0
 then
;
\
\ * *************************************************************************
\
\ *-
\ *Z
\