\   

S" SAMPLES\SOCKETS.TXT" INCLUDED
S" SAMPLES\THREAD.TXT"  INCLUDED
\ : PICK ;
\ S" INCLUDE\TOOLS.F" INCLUDED
S" INCLUDE\FACIL.F" INCLUDED

VARIABLE HTTPVER
: HTTP1? ( -- flag )
  HTTPVER @
;
: HTTP/1.0
  1 HTTPVER !
;
: Get1 \    HTTP-
( addr u S" www.enet.ru" 80 S" \win\cherezov\index.html" -- )
  2>R >R GetHostIP THROW
  R> CreateSocket THROW DUP >R
  ConnectSocket THROW
  S" GET " R@ WriteSocket THROW
  R> 2R> ROT >R R@ WriteSocket THROW
  HTTP1? IF
    S"  HTTP/1.0" R@ WriteSocketLine THROW
    S" Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*"
    R@ WriteSocketLine THROW
    S" Accept-Language: ru" R@ WriteSocketLine THROW
  THEN
  R@ WriteSocketCRLF THROW
  BEGIN
    2DUP R@ ReadSocket THROW ?DUP
  WHILE
    >R OVER R> TYPE
  REPEAT 2DROP
  R> CloseSocket THROW
;
: GET ( " www.enet.ru /win/cherezov/index.html" -- )
  SocketsStartup THROW
  PAD 10000 BL SKIP BL PARSE 2DUP + 0 SWAP C! 80
  BL SKIP BL PARSE 2DUP + 0 SWAP C! Get1
  SocketsCleanup THROW
;
VARIABLE READ-POINT

: READ-TYPE ( s -- )
  READ-POINT 0!
  >R
  BEGIN
    R@ ToRead THROW 2 >
  UNTIL
  BEGIN
    PAD R@ ToRead THROW DUP
  WHILE
    R@ ReadSocket THROW
    PAD SWAP DUP READ-POINT +! TYPE
  REPEAT 2DROP R> DROP
;
CREATE CRLF.CRLF 13 C, 10 C, CHAR . C, 13 C, 10 C,
0 VALUE PAD2

: READTO. ( s -- )
  HERE 20000 + TO PAD2
  READ-POINT 0!
  >R
\  BEGIN
\    R@ ToRead THROW 2 >
\  UNTIL
  BEGIN
  BEGIN
    PAD2 READ-POINT @ + R@ ToRead THROW DUP
  WHILE
    R@ ReadSocket THROW
    PAD2 READ-POINT @ + SWAP DUP READ-POINT +! TYPE
  REPEAT 2DROP
  PAD2 READ-POINT @ CRLF.CRLF 5 SEARCH NIP NIP
  UNTIL R> DROP
;
: READ-TO-CR ( s -- )
  >R
  BEGIN
    HERE 1 R@ ReadSocket THROW 1 =
    HERE C@ 13 <> AND
  WHILE
    HERE C@ EMIT
  REPEAT HERE 1 R@ ReadSocket THROW DROP CR
  R> DROP
;
: CRLF>BL ( addr u -- )
  0 ?DO DUP I + C@ BL < IF BL OVER I + C! THEN LOOP DROP
;
: .>_ ( addr u -- )
  0 ?DO DUP I + C@ [CHAR] . = IF [CHAR] _ OVER I + C! THEN LOOP DROP
;
: />\ ( addr u -- )
  0 ?DO DUP I + C@ [CHAR] / = IF [CHAR] \ OVER I + C! THEN LOOP DROP
;
VARIABLE LOG TRUE LOG !
: WriteSocket
  LOG @ IF >R 2DUP TYPE R> THEN WriteSocket
;
: WriteSocketLine
  LOG @ IF >R 2DUP TYPE CR R> THEN WriteSocketLine
;
: WriteSocketCRLF
  LOG @ IF CR THEN WriteSocketCRLF
;
: MAIL-INDEX ( -- addr2 addr1 )
  HERE
  TIB >R >IN @ >R #TIB @ >R
  PAD2 TO TIB READ-POINT @ #TIB ! >IN 0!
  13 PARSE 2DROP
  SOURCE CRLF>BL
  BEGIN
    BL WORD COUNT 2DUP S" ." COMPARE 0<> OVER 0 > AND
  WHILE
    0 0 2SWAP >NUMBER 2DROP D>S ,
  REPEAT 2DROP
  R> #TIB ! R> >IN ! R> TO TIB
  HERE SWAP
;
VARIABLE DELE?

: RECV-MAIL ( "enet.ru mboxname password" -- )
  SocketsStartup THROW
  BL SKIP BL PARSE 2DUP + 0 SWAP C!
  GetHostIP THROW 110 CreateSocket THROW DUP >R
  ConnectSocket THROW R@ READ-TYPE
  S" USER " R@ WriteSocket THROW BL WORD COUNT R@ WriteSocket THROW
  R@ WriteSocketCRLF THROW
  R@ READ-TYPE
  S" PASS " R@ WriteSocket THROW BL WORD COUNT R@ WriteSocket THROW
  R@ WriteSocketCRLF THROW
  R@ READ-TYPE
  S" LIST" R@ WriteSocket THROW
  R@ WriteSocketCRLF THROW
\  R@ READ-TO-CR
  R@ READTO. MAIL-INDEX
  R@ HERE !
  ?DO
    S" RETR " HERE @ WriteSocket THROW
    I @ 0 <# #S #>
    HERE @ WriteSocket THROW
    HERE @ WriteSocketCRLF THROW
    HERE @ READTO.
    DELE? @ IF
      S" DELE " HERE @ WriteSocket THROW
      I @ 0 <# #S #>
      HERE @ WriteSocket THROW
      HERE @ WriteSocketCRLF THROW
      HERE @ READ-TYPE
    THEN
  2 CELLS +LOOP
  S" QUIT" R@ WriteSocket THROW
  R@ WriteSocketCRLF THROW
  R@ READ-TYPE
  R> CloseSocket THROW
  SocketsCleanup THROW
;
: WaitRETR ( -- flag )
  BEGIN
    REFILL
  WHILE
    BL WORD COUNT S" RETR" COMPARE 0= IF REFILL EXIT THEN
  REPEAT
  FALSE
;
VARIABLE COUNT?
VARIABLE TYPE?
VARIABLE LINES
0 VALUE M-PATH
VARIABLE NO-CREATE?
: NO-CREATE TRUE NO-CREATE? ! ;

: MemoTo:
  BL WORD DROP \ To:
  BL SKIP
  TIB >IN @ + C@ [CHAR] " =
  IF [CHAR] " WORD DROP BL SKIP THEN
  TIB >IN @ + C@ [CHAR] < =
  IF >IN 1+! #TIB @ 1- #TIB ! THEN
  [CHAR] @ WORD COUNT
  2DUP S" <" SEARCH
  IF 2DROP 2DROP >IN 0! [CHAR] < WORD DROP #TIB @ 1- #TIB !
     [CHAR] @ WORD COUNT
  ELSE 2DROP THEN  2DUP .>_
  2DUP 2>R M-PATH COUNT + SWAP MOVE
  M-PATH COUNT 2R> NIP + 2DUP + 0!
  2DUP R/W OPEN-FILE
  IF DROP NO-CREATE? @ 0= IF R/W CREATE-FILE
                          ELSE 2DROP EXIT THEN
     IF DROP EXIT THEN
  ELSE NIP NIP THEN
  >R R@ FILE-SIZE THROW R@ REPOSITION-FILE THROW
  R> TO H-STDOUT
;
: ReadMessage ( -- )
  LINES 0! COUNT? 0!
  BEGIN
    REFILL SOURCE S" ." COMPARE 0<> AND
  WHILE
    COUNT? @ TYPE? @ 0= AND IF LINES 1+! THEN
    SOURCE NIP 0= IF TRUE COUNT? ! THEN
    SOURCE 4 MIN 2DUP S" To: " COMPARE 0= >R
    S" TO: " COMPARE 0= R> OR
    COUNT? @ 0= AND
    TYPE? @ 0= AND
    IF MemoTo: THEN
    SOURCE
    SOURCE DROP C@ [CHAR] . = SOURCE NIP 0 > AND
    IF 1- SWAP 1+ SWAP THEN
    TYPE? @ IF TYPE CR ELSE 2DROP THEN
  REPEAT
;
: TO-DMAIL ( "file1" "path" -- )
  BL WORD COUNT R/O OPEN-FILE THROW TO SOURCE-ID
  BL WORD HERE TO M-PATH ", 100 ALLOT
  BEGIN
    WaitRETR
  WHILE
    H-STDOUT >R
    SOURCE-ID FILE-POSITION THROW 2>R FALSE TYPE? !
    ReadMessage
    2R> SOURCE-ID REPOSITION-FILE THROW TRUE TYPE? !
    ." From postmaster Fri Oct 25 18:14:29 1996" CR
    ." Lines: " LINES @ . CR
    ReadMessage CR
    H-STDOUT DUP R@ <> IF CLOSE-FILE THROW ELSE DROP THEN
    R> TO H-STDOUT
  REPEAT POSTPONE \ BYE
;
: WaitFrom
  BEGIN
    UNIX-LINES
    REFILL 0= IF FALSE EXIT THEN
    SOURCE 5 MIN S" From " COMPARE 0=
  UNTIL TRUE
;
VARIABLE LineD
VARIABLE TO:V
VARIABLE FROM:V
VARIABLE TO:V2
VARIABLE FROM:V2
VARIABLE SUBJ:V
VARIABLE NEWS:V
VARIABLE DATE:V

: SEND-DMAIL ( "enet.ru file" -- )
  SocketsStartup THROW
  BL SKIP BL PARSE 2DUP + 0 SWAP C!
  GetHostIP THROW 25 CreateSocket THROW DUP >R
  ConnectSocket THROW R@ READ-TYPE
  S" HELO enet.ru" R@ WriteSocket THROW R@ WriteSocketCRLF THROW
  R@ READ-TYPE
  BL WORD COUNT R/O OPEN-FILE THROW TO SOURCE-ID

  BEGIN
    LINES 0! COUNT? 0!
    FROM:V 0! TO:V 0!
    FROM:V2 0! TO:V2 0!
    SUBJ:V 0! DATE:V 0!
    NEWS:V 0!
    WaitFrom
  WHILE
    BEGIN
      UNIX-LINES
      LineD 0!
      REFILL LINES @ 0< 0= AND
    WHILE
      DOS-LINES
      SOURCE NIP 0= COUNT? @ 0= AND
      IF 
         S" MAIL FROM:<" R@ WriteSocket THROW
         FROM:V @ ?DUP IF COUNT R@ WriteSocket THROW
         S" >" R@ WriteSocket THROW
         R@ WriteSocketCRLF THROW
         R@ READ-TYPE THEN
         TO:V @ 0=
         IF S" TO:<bug@cherezov.koenig.su>" R@ WriteSocketLine THROW R@ READ-TYPE
         ELSE
         TO:V @
         BEGIN
           DUP C@
         WHILE
           S" RCPT TO:<" R@ WriteSocket THROW
           COUNT 2DUP R@ WriteSocket THROW S" >" R@ WriteSocket THROW
           R@ WriteSocketCRLF THROW
           R@ READ-TYPE
           +
         REPEAT DROP
         THEN
         S" DATA" R@ WriteSocket THROW
         R@ WriteSocketCRLF THROW
         R@ READ-TYPE
         \    
         S" From: " R@ WriteSocket THROW
         FROM:V2 @ COUNT R@ WriteSocket THROW
         R@ WriteSocketCRLF
         S" To: " R@ WriteSocket THROW
         TO:V2 @ COUNT R@ WriteSocket THROW
         R@ WriteSocketCRLF
         SUBJ:V @ IF
         S" Subject: " R@ WriteSocket THROW
         SUBJ:V @ COUNT R@ WriteSocket THROW
         R@ WriteSocketCRLF THEN
         DATE:V @ IF
         S" Date: " R@ WriteSocket THROW
         DATE:V @ COUNT R@ WriteSocket THROW
         R@ WriteSocketCRLF THEN
         NEWS:V @ IF
         S" Newsgroups: " R@ WriteSocket THROW
         NEWS:V @ COUNT R@ WriteSocket THROW
         R@ WriteSocketCRLF THEN
         S" X-Mailer: dMail/DOS+POP3SMTP/WIN32 v0.1" R@ WriteSocketLine THROW
         S" MIME-Version: 1.0" R@ WriteSocketLine THROW
         S" Content-Type: text/plain; charset=KOI8-R" R@ WriteSocketLine THROW
         S" Content-Transfer-Encoding: 8bit" R@ WriteSocketLine THROW
         
         R@ WriteSocketCRLF \    
         TRUE COUNT? !
      THEN
      SOURCE 4 MIN 2DUP S" To: " COMPARE 0= >R
      S" TO: " COMPARE 0= R> OR COUNT? @ 0= AND
      IF BL WORD DROP HERE TO:V !
         BEGIN
           [CHAR] , WORD DUP C@
         WHILE
            ",
         REPEAT DROP 0 C,
         TRUE LineD !
         >IN 0! BL WORD DROP HERE TO:V2 ! 1 WORD ",
      THEN
      SOURCE 6 MIN 2DUP S" From: " COMPARE 0= >R
      S" FROM: " COMPARE 0= R> OR COUNT? @ 0= AND
      IF HERE FROM:V !
         BEGIN
           [CHAR] < WORD DROP [CHAR] > WORD DUP C@
         WHILE
            ",
         REPEAT DROP 0 C,
         >IN 0! BL WORD DROP HERE FROM:V2 ! 1 WORD ",
         TRUE LineD !
      THEN
      SOURCE 7 MIN 2DUP S" Lines: " COMPARE 0= >R
      S" LINES: " COMPARE 0= R> OR COUNT? @ 0= AND
      IF BL WORD DROP 0 0 BL SKIP BL PARSE >NUMBER 2DROP D>S
         LINES !
      THEN
      SOURCE 9 MIN 2DUP S" Subject: " COMPARE 0= >R
      S" SUBJECT: " COMPARE 0= R> OR COUNT? @ 0= AND
      IF BL WORD DROP HERE SUBJ:V ! 1 WORD ",
      THEN
      SOURCE 6 MIN 2DUP S" Date: " COMPARE 0= >R
      S" DATE: " COMPARE 0= R> OR COUNT? @ 0= AND
      IF BL WORD DROP HERE DATE:V ! 1 WORD ",
      THEN
      SOURCE 9 MIN 2DUP S" Newsgroup" COMPARE 0= >R
      S" NEWSGROUP" COMPARE 0= R> OR COUNT? @ 0= AND
      IF BL WORD DROP HERE NEWS:V ! 1 WORD ",
      THEN
      SOURCE S" ." COMPARE 0=
      IF S" .." R@ WriteSocket THROW R@ WriteSocketCRLF THROW
         TRUE LineD !
      THEN
      LineD @ 0= COUNT? @ AND
      IF SOURCE R@ WriteSocket THROW R@ WriteSocketCRLF THROW THEN
      COUNT? @ IF LINES @ 1- LINES ! THEN
    REPEAT
    S" ." R@ WriteSocket THROW R@ WriteSocketCRLF THROW
    R@ READ-TYPE
  REPEAT
  S" QUIT" R@ WriteSocket THROW R@ WriteSocketCRLF THROW
  R@ READ-TYPE BYE
;
: OEM
  ['] ANSI>OEM TO ANSI><OEM
;
: DOS OEM ;
: DELE TRUE DELE? ! ;
: AcceptPort ( N -- s )
  SocketsStartup THROW
  CreateSocket THROW >R
  R@ BindSocket THROW
  R@ ListenSocket THROW
  R> AcceptSocket THROW
;
VARIABLE CUR-TALK
VARIABLE CLIENTS-LIST
VARIABLE TALK-MESSAGE

: WRITE-TO-CLIENTS ( addr u -- )
  CLIENTS-LIST @ >R
  BEGIN
    R@
  WHILE
    2DUP R@ CELL+ @ ?DUP
    IF WriteSocket IF R@ CELL+ 0! THEN
    ELSE 2DROP THEN
    R> @ >R
  REPEAT R> DROP 2DROP
;
: (WRITE-THREAD)
  INIT-THREAD
  100 ALLOT
  HERE >R 500 ALLOT
  BEGIN
    R@ 500 ACCEPT
    S" TALK-SERVER v0.1: " WRITE-TO-CLIENTS
    R@ SWAP WRITE-TO-CLIENTS
    CRLF.CRLF 2 WRITE-TO-CLIENTS
    S" CONNECTED" R@ OVER COMPARE 0=
    IF  CLIENTS-LIST @ >R
        BEGIN
          R@
        WHILE
          R@ CELL+ @ ?DUP 
          IF GetPeerName DROP WRITE-TO-CLIENTS THEN
          S" , " WRITE-TO-CLIENTS
          R> @ >R
        REPEAT R> DROP CRLF.CRLF 2 WRITE-TO-CLIENTS
    THEN
  AGAIN
  R> DROP 0
;
' (WRITE-THREAD) WNDPROC: WRITE-THREAD

: (TALK-THREAD)
  INIT-THREAD
  100 ALLOT
  HERE >R
  CLIENTS-LIST @ ,
  CUR-TALK @ , 0 , R@ CLIENTS-LIST !
  500 ALLOT
  S" TALK-SERVER v0.1: Hello! " CUR-TALK @ WriteSocket DROP
  TALK-MESSAGE @ COUNT CUR-TALK @ WriteSocketLine DROP
  BEGIN
    R@ 2 CELLS + 0!
    BEGIN
      R@ 3 CELLS + R@ 2 CELLS + @ +
      500 R@ 2 CELLS + @ -
      R@ CELL+ @ ReadSocket
      IF DROP R> CELL+ DUP @ CloseSocket DROP 0! 0 ExitThread
      ELSE R@ 2 CELLS + +! THEN
      R@ 3 CELLS +  R@ 2 CELLS + @ CRLF.CRLF 1 SEARCH NIP NIP
    UNTIL
    R@ CELL+ @ GetPeerName DROP WRITE-TO-CLIENTS
    S" : " WRITE-TO-CLIENTS
    R@ 3 CELLS +  R@ 2 CELLS + @ 2DUP TYPE WRITE-TO-CLIENTS
  AGAIN
  R> DROP 0
;
' (TALK-THREAD) WNDPROC: TALK-THREAD

: TALK-SERVER ( "port message" -- )
  0 0 BL WORD COUNT >NUMBER 2DROP D>S
  HERE TALK-MESSAGE ! 1 WORD ",
  SocketsStartup THROW
  CreateSocket THROW >R
  R@ BindSocket THROW
  R@ ListenSocket THROW
  ['] WRITE-THREAD CREATE-THREAD DROP
  BEGIN
    R@ AcceptSocket THROW DUP CUR-TALK ! GetPeerName DROP TYPE SPACE
    ['] TALK-THREAD CREATE-THREAD DROP
  AGAIN
  R> DROP
;
VARIABLE WEB-DIR
VARIABLE MUT

: WEB-ANSWER ( addr u R -- )
  FALSE LOG !
  >R
\  OVER 3 S" GET" COMPARE 0= IF R> DROP 2DROP EXIT THEN
  2DUP />\ 
  TIB >R >IN @ >R #TIB @ >R
  #TIB ! >IN 0! TO TIB
  BL WORD DROP >IN 1+! BL PARSE
  R> #TIB ! R> >IN ! R> TO TIB 2DUP + 0!
  DUP 0= IF DROP S" index.html" DUP >R HERE CELL+ SWAP 1+ MOVE HERE CELL+ R> THEN
  2 + SWAP 2 - [CHAR] . OVER C! [CHAR] \ OVER 1+ C! SWAP
  2DUP TYPE CR
  2DUP R/O OPEN-FILE
  IF DROP S" HTTP/1.0 400 Bad Request" R@ CELL+ @ WriteSocketLine DROP
     S" Content-Type: text/html" R@ CELL+ @ WriteSocketLine DROP
     R@ CELL+ @ WriteSocketCRLF DROP
     S" <BODY><H1>  :</H1></BODY>" R@ CELL+ @ WriteSocketLine DROP
     R> CELL+ @ WriteSocketLine DROP
     ." BAD REQUEST" CR
     EXIT
  THEN NIP NIP
  R@ 4 CELLS + !
  S" HTTP/1.0 200 OK" R@ CELL+ @ WriteSocketLine DROP
  S" Server: SP-Forth-PWS/0.1" R@ CELL+ @ WriteSocketLine DROP
  R@ CELL+ @ WriteSocketCRLF DROP
  BEGIN
    R@ 5 CELLS + 400 R@ 4 CELLS + @ READ-FILE
    IF DROP R> 4 CELLS + @ CLOSE-FILE DROP EXIT THEN
    ?DUP
  WHILE
    R@ 5 CELLS + SWAP R@ CELL+ @ WriteSocket DROP
  REPEAT
  R> 4 CELLS + @ CLOSE-FILE DROP
;
CREATE CRLFCRLF 13 C, 10 C, 13 C, 10 C,

: (WEB-THREAD)
  INIT-THREAD
  500 ALLOCATE THROW >R
  CLIENTS-LIST @ R@ !
  CUR-TALK @ R@ CELL+ !
  BEGIN
    R@ 2 CELLS + 0!
    BEGIN
      R@ 3 CELLS + R@ 2 CELLS + @ +
      500 R@ 2 CELLS + @ -
      R@ CELL+ @ ReadSocket
      IF DROP R@ CELL+ DUP @ CloseSocket DROP 0! 0 R> FREE . ExitThread
      ELSE R@ 2 CELLS + +! THEN
      R@ 3 CELLS +  R@ 2 CELLS + @ CRLFCRLF 4 SEARCH NIP NIP
    UNTIL
\    R@ CELL+ @ GetPeerName DROP TYPE
\    S" : " TYPE
    R@ 3 CELLS +  R@ 2 CELLS + @ ( 2DUP TYPE CR) R@ WEB-ANSWER
    R@ CELL+ @ CloseSocket DROP R@ FREE . 0 ExitThread
  AGAIN
  R> DROP 0
;
' (WEB-THREAD) WNDPROC: WEB-THREAD

: WEB-SERVER ( "port dir" -- )
  0 0 BL WORD COUNT >NUMBER 2DROP D>S
  HERE WEB-DIR ! 1 WORD ",
  SocketsStartup THROW
  CreateSocket THROW >R
  R@ BindSocket THROW
  R@ ListenSocket THROW
  BEGIN
    R@ AcceptSocket THROW DUP CUR-TALK !
    GetPeerName DROP CR TYPE ." : "
    ['] WEB-THREAD CREATE-THREAD DROP 1000000 0 DO NOOP LOOP 
  AGAIN
  R> DROP
;
WINAPI: RasDialA RASAPI32.DLL
WINAPI: RasHangUpA RASAPI32.DLL
\ : RasDialA ;
\ : RasHangUpA ;

0
4 -- dwSize
( 21)
257 -- szEntryName
129 -- szPhoneNumber
( 49)
129 -- szCallbackNumber
257 -- szUserName
257 -- szPassword
 19 --  szDomain
\ 736 - win95

CONSTANT /RASDIALPARAMS \ Win95 & winNT
VARIABLE RASCONN

VARIABLE HH
VARIABLE MM

: WAIT ( "time" -- )
  BL SKIP 0 0 [CHAR] : PARSE >NUMBER 2DROP D>S HH !
  0 0 BL PARSE >NUMBER 2DROP D>S MM !
  BEGIN
    TIME&DATE 2DROP DROP ROT DROP
    HH @ = >R
    MM @ 1- > R> AND
  UNTIL
;
: HANGUP ( -- )
  RASCONN @ RasHangUpA DROP
;
: DIAL ( "entry-name phone name passw domain" -- )
  RASCONN 0!
  /RASDIALPARAMS ALLOCATE THROW >R
  R@ /RASDIALPARAMS ERASE BL WORD COUNT R@ szEntryName SWAP MOVE
  BL WORD COUNT 2DUP S" *" COMPARE 0=
  IF 2DROP ELSE R@ szPhoneNumber SWAP MOVE THEN
  BL WORD COUNT R@ szUserName SWAP MOVE
  BL WORD COUNT R@ szPassword SWAP MOVE
  BL WORD COUNT R@ szDomain SWAP MOVE
  /RASDIALPARAMS R@ !
  BEGIN
    RASCONN 0 0 R@ ( RASDIALPARAMS) 0 0 RasDialA
    DUP 0<>
    IF TIME&DATE 2DROP DROP CR ." DIAL: " . . DROP
       ." Error: " DUP . ." retry..." HANGUP
    THEN
    0= KEY? OR
  UNTIL KEY? IF KEY DROP THEN
  R> FREE THROW
;
1000 TO C/L S" TestIP.exe" SAVE
