(*
 * LANGUAGE    : ANS Forth
 * PROJECT     : Forth Environments
 * DESCRIPTION : Get news using NNTP, see RFC-0977
 * CATEGORY    : Utility 
 * AUTHOR      : Marcel Hendrix 
 * LAST CHANGE : Saturday, March 01, 2003 12:15 PM, Marcel Hendrix, test for '..' at start of line. 
 * LAST CHANGE : Saturday, May 17, 2003 2:48 PM, Marcel Hendrix; adjusted Cook filter for \nFrom: 
 * LAST CHANGE : Wednesday, December 18, 2002 3:04 AM, Marcel Hendrix 
 * LAST CHANGE : Tuesday, December 24, 2002 8:40 PM, Marcel Hendrix; sstream
 * LAST CHANGE : Wednesday, December 25, 2002 1:42 AM, Marcel Hendrix; multiple group
 *)

	NEEDS -miscutil
	NEEDS -sstream
	NEEDS -dilbert

	REVISION -news "--- News with NNTP      Version 1.05 ---"

	PRIVATES

DOC
(*
   Use socket API functions to perform news acquisition using NNTP. 
   Connect to an (internally specified) NNTP server. Write new news
   to 'newsfile'. The article-last-read pointer is in 'markerfile'.
*)
ENDDOC

-- standard tools ----------------------------------------------------------------------------

0 VALUE nstate  	PRIVATE
0 VALUE file		PRIVATE

SSTREAM [sock]		PRIVATE
CREATE  perr 		PRIVATE	   3 CHARS ALLOT	-- buffers error number from server
CREATE  response$	PRIVATE	#256 CHARS ALLOT	-- buffers response from server
0 VALUE #resp		PRIVATE				-- response size

WARNING @ WARNING OFF	VARIABLE debug? debug? OFF	WARNING !

: .debug  ( c-addr u -- ) DUP debug? @ AND IF  ^M EMIT '[' EMIT .TIME ." ] " TYPE EXIT  ENDIF 2DROP ; PRIVATE
: <semit> ( char -- )     DUP EOF = IF  DROP ." <EOF>"  ELSE  EMIT  ENDIF ; PRIVATE
: ?emit   ( char -- )     debug? @ IF  <semit> EXIT  ENDIF DROP ; PRIVATE
: FSEND$  ( c-addr u -- ) 0 ?DO  C@+ SPUTCH [sock]  LOOP DROP ; PRIVATE ( do a timely flush! )
: SEND$   ( c-addr u -- ) FSEND$  SFLUSH [sock] ; PRIVATE
: CHAR1   ( -- c ) 	  BEGIN  SGETCH [sock] DUP EOF =  WHILE  DROP  REPEAT ; PRIVATE
: !char	  ( c -- )	  response$ #resp +  C!  #resp 1+ #255 AND TO #resp ; PRIVATE

: EAT-ALL ( -- )
	CLEAR #resp
	CHAR1 DUP ?emit !char 
	BEGIN  SGETCH [sock] DUP ?emit DUP !char DUP EOF = SWAP ^J = OR  UNTIL ; PRIVATE

-- Errors are in perr. It is not necessary to translate them.
: .REPORT-ERRORS ( bool -- ) 
	0= ?EXIT
	CR ." Error " perr 3 TYPE SPACE response$ #resp TYPE
	TRUE ABORT" protocol error" ; PRIVATE

: cmd? ( c-addr u -- TRUE=error )
	+CR 2DUP .debug SEND$
	CHAR1         DUP ?emit  perr           C!
	SGETCH [sock] DUP ?emit  perr   CHAR+   C!
	SGETCH [sock] DUP ?emit  perr 2 CHARS + C!
	perr C@ '3' > >S ( > 4xx is protocol error; see RFC 0977 )
	 EAT-ALL 
	S> ; PRIVATE 

: cmd ( c-addr u -- ) cmd? .REPORT-ERRORS ; PRIVATE 

: $>num ( c-addr1 u1 -- c-addr2 u2 u3 )
	BL SKIP  BL Split-At-Char  2SWAP 
	BASE @ >S  DECIMAL  NUMBER?  S> BASE !
	1 <> ABORT" $>num :: invalid number" ; PRIVATE

: CLEAR-STATE CLEAR nstate ; PRIVATE

: ..?  ( char -- bool? ) '.' =  nstate 3 = AND ; PRIVATE

: END? ( char -- bool? )
	LOCAL c
	nstate 0 = IF  c ^M  = IF 1 	     ELSE 		   0 	   ENDIF TO nstate FALSE EXIT  ENDIF 
	nstate 1 = IF  c ^J  = IF 2          ELSE c ^M = IF 1 ELSE 0 ENDIF ENDIF TO nstate FALSE EXIT  ENDIF 
	nstate 2 = IF  c '.' = IF 3          ELSE c ^M = IF 1 ELSE 0 ENDIF ENDIF TO nstate FALSE EXIT  ENDIF 
	nstate 3 = IF  c ^M  = IF 4 	     ELSE 		   0       ENDIF TO nstate FALSE EXIT  ENDIF 
	nstate 4 = IF  c ^J  = IF TRUE EXIT  ELSE c ^M = IF 1 ELSE 0 ENDIF ENDIF TO nstate FALSE EXIT  ENDIF ; PRIVATE

: separator ( c-addr u -- )
	$CR COUNT    S" ----------------*-----------------*----------------- " $+ 
	2SWAP $+     S"  ---------------*-----------------*----------------- " $+
	+CR +CR file WRITE-FILE ?FILE ; PRIVATE

DEFER KOOK? ( c-addr u -- TRUE=kook )  PRIVATE

: ?store-it ( bool c-addr u -- TRUE=plonked )
	ROT IF  2DROP ." *UNAVAILABLE* " TRUE EXIT  ENDIF
	separator
	0 0 TRUE LOCALS| first? plonk? p |
	CLEAR-STATE
	BEGIN
	  SGETCH [sock] DUP EOF 
	  <> IF	 DUP ..? 0= IF  DUP PAD p + C!  1 +TO p  ENDIF
		 p #4096  > IF  first? IF  PAD p KOOK? TO plonk?  CLEAR first?  ENDIF 
		 		plonk? 0= IF  PAD p file WRITE-FILE ?FILE  ENDIF
				CLEAR p
		 	 ENDIF
		 ( char) END?
	   ELSE  DROP FALSE
	  ENDIF
	UNTIL ( delete .^M^J when possible -> 3 - )
	first? IF  PAD p KOOK? TO plonk?  ENDIF 
	plonk? 0= IF  PAD p 3 - 0 MAX file WRITE-FILE ?FILE  ENDIF 
	plonk? ; PRIVATE

-- -------------------------------------------------------------------------------------------

 #119 =: IPPORT_NNTP	PRIVATE	-- standard NNTP port address

CREATE server		PRIVATE ," news.chello.nl"
CREATE markerfile	PRIVATE ," ./idata/newsrc.bin"

CREATE newsmarker	PRIVATE	0 ,
0 VALUE GROUPNAME	PRIVATE
0 VALUE NEWSFILE	PRIVATE
0 VALUE SLOT		PRIVATE
0 VALUE NEXTGROUP	PRIVATE
0 VALUE SUSPENDED?	PRIVATE
0 VALUE groupchain	PRIVATE

: NEWSGROUP ( slot# "name" "database" -- )
	CREATE	( slot) , HERE >S  0 , 0 , groupchain ,  0 ,
		HERE S        !  BL WORD C@ 1+ ALLOT
		HERE S  CELL+ !  BL WORD C@ 1+ ALLOT
		BL WORD COUNT >FLOAT 0= THROW F>S  S> 3 CELL[] !
		@LATEST HEAD> @ TO groupchain
	DOES>	@+ TO SLOT
		@+ TO GROUPNAME
		@+ TO NEWSFILE 
		@+ TO NEXTGROUP
		@  TO SUSPENDED? ; PRIVATE

-- Define wanted newsgroups -----------------------------------------------------------------

\								     suspended?	
	0 NEWSGROUP clf  comp.lang.forth 	./idata/clfnews.dat	0
	1 NEWSGROUP sci  sci.math.num-analysis  ./idata/scinews.dat	1
	2 NEWSGROUP dcl  de.comp.lang.forth	./idata/declf.dat	0
	3 NEWSGROUP cfn	 comp.lang.fortran	./idata/cfortran.dat	1

CREATE \nFrom: PRIVATE #16 CHARS ALLOT 
	$CR COUNT  \nFrom: PACK DROP
	S" From: " \nFrom: PLACE+
CREATE kook$ PRIVATE #80 CHARS ALLOT 

: \nSEARCH ( c-addr u c-addr2 u2 -- c-addr3 u3 bool )
	\nFrom: COUNT kook$ PACK DROP  kook$ PLACE+  
	kook$ COUNT SEARCH ; PRIVATE

: test 	( c-addr1 u1 -- c-addr2 u2 ) OVER  $CR COUNT  TUCK COMPARE IF  $CR COUNT 2SWAP $+  ENDIF ;

:NONAME ( c-addr u -- TRUE=kook ) \ Remove the worst kooks & assorted kwebbeltantes
	debug? @ IF  CR ." PLONK: "  2DUP #60 MIN TYPE ." ..."  ENDIF
	DUP $CR C@ > IF  OVER  $CR COUNT  TUCK COMPARE IF  $CR COUNT 2SWAP $+  ENDIF  ENDIF
	S" johnmdrake@gmail.com"				\nSEARCH IF  2DROP CR  ." *Drake PLOOKED* " 	  TRUE EXIT  ENDIF
	S" jpd@wispertel.net"					\nSEARCH IF  2DROP CR  ." *Doty PLOOKED* " 	  TRUE EXIT  ENDIF
	S~ "werty"~						\nSEARCH IF  2DROP CR  ." *werty PLOOKED* " 	  TRUE EXIT  ENDIF
	S" Aleksej Saushev <asau@hotbox.ru>"			\nSEARCH IF  2DROP CR  ." *Al Saus PLOOKED* " 	  TRUE EXIT  ENDIF
	S" Don Seglio <don.seglio@sbcglobal.net>"		\nSEARCH IF  2DROP CR  ." *Don Seglio PLOOKED* "  TRUE EXIT  ENDIF
	S~ fox@ultratechnology.com~				\nSEARCH IF  2DROP CR  ." *Fox PLOOKED* "         TRUE EXIT  ENDIF
	S~ "jacko" <jackokring@gmail.com>~			\nSEARCH IF  2DROP CR  ." *jacko PLONKED* " 	  TRUE EXIT  ENDIF
	S~ "bobjaffray@juno.com" <bobjaffray@juno.com>~		\nSEARCH IF  2DROP CR  ." *Bob Jaffray PLONKED* " TRUE EXIT  ENDIF
	S" crypto_stonelock@hotmail.com"			\nSEARCH IF  2DROP CR  ." *crypto PLOOKED* "      TRUE EXIT  ENDIF
	S" forthfreak <forthfreak@forth.net>"			\nSEARCH IF  2DROP CR  ." *forthfreak PLOOKED* "  TRUE EXIT  ENDIF
	S~ "rickman" <gnuarm@gmail.com>~			\nSEARCH IF  2DROP CR  ." *Rickman PLOOKED* "     TRUE EXIT  ENDIF
	S" mattparker@best.ge"					\nSEARCH IF  2DROP CR  ." *Matt P. PLOOKED* "     TRUE EXIT  ENDIF
	S" i440r@mailcity.com (Mark Manning)"			\nSEARCH IF  2DROP CR  ." *Manning PLOOKED* " 	  TRUE EXIT  ENDIF
	S" Guy Macon <http://www.guymacon.com>"			\nSEARCH IF  2DROP CR  ." *Guy Macon PLOOKED* "   TRUE EXIT  ENDIF
	S" agila61@netscape.net (Dr. Bruce R. McFarling)"	\nSEARCH IF  2DROP CR  ." *Dr. Bruce PLOOKED* "   TRUE EXIT  ENDIF
	S~ "Bruce McFarling" <agila61@netscape.net>~		\nSEARCH IF  2DROP CR  ." *Dr. Bruce PLOOKED* "   TRUE EXIT  ENDIF
	S~ "John Passaniti" <nntp@JapanIsShinto.com>~		\nSEARCH IF  2DROP CR  ." *Passaniti PLOOKED* "   TRUE EXIT  ENDIF
	S" japeters@pacbell.net (John A. Peters)"		\nSEARCH IF  2DROP CR  ." *Peters PLOOKED* "      TRUE EXIT  ENDIF
	S~ "John Peters" <japeters@pacbell.net>~		\nSEARCH IF  2DROP CR  ." *Peters PLOOKED* "      TRUE EXIT  ENDIF
	S~ "John A. Peters" <japeters@pacbell.net>~		\nSEARCH IF  2DROP CR  ." *Peters PLOOKED* "      TRUE EXIT  ENDIF
	S" John Peters <japeters@pacbell.net>"			\nSEARCH IF  2DROP CR  ." *Peters PLOOKED* "      TRUE EXIT  ENDIF
	S~ "John Doty" <jpd@w-d.org>~				\nSEARCH IF  2DROP CR  ." *Doty PLOOKED* "     	  TRUE EXIT  ENDIF
	S" John Doty <jpd@whispertel.LoseTheH.net>"		\nSEARCH IF  2DROP CR  ." *Doty PLOOKED* "     	  TRUE EXIT  ENDIF
	S~ "Jeff Fox" <fox@ultratechnology.com>~		\nSEARCH IF  2DROP CR  ." *Fox PLOOKED* "         TRUE EXIT  ENDIF
	S" fox@ultratechnology.com (Jeff Fox)"			\nSEARCH IF  2DROP CR  ." *Fox PLOOKED* "         TRUE EXIT  ENDIF
	S" ernobe <ernobe@yahoo.com>"				\nSEARCH IF  2DROP CR  ." *ernobe PLOOKED* "      TRUE EXIT  ENDIF
	S" astrobe@netcourrier.com (Astrobe)"			\nSEARCH IF  2DROP CR  ." *Astrobe PLOOKED* "     TRUE EXIT  ENDIF
	S" Guido Draheim <guidod-2003-@gmx.de>"			\nSEARCH IF  2DROP CR  ." *Guido PLOOKED* "       TRUE EXIT  ENDIF
	S" jmdrake_98@yahoo.com (jmdrake)"     			\nSEARCH IF  2DROP CR  ." *jmdrake_98 PLOOKED* "  TRUE EXIT  ENDIF
	S" ppaatt@aol.com (Pat LaVarre)" 			\nSEARCH IF  2DROP CR  ." *ppaat PLOOKED* "       TRUE EXIT  ENDIF
	S" azedia@dolfina.org (geakazoid)"	 		\nSEARCH IF  2DROP CR  ." *Dolfina PLOOKED* "     TRUE EXIT  ENDIF
	S" wtanksleyjr@cox.net (William Tanksley Google)"	\nSEARCH IF  2DROP CR  ." *Tanksley PLOOKED* "    TRUE EXIT  ENDIF
	S" kc5tja@arrl.net (Samuel A. Falvo II)"		\nSEARCH IF  2DROP CR  ." *kc5tja PLOOKED* "      TRUE EXIT  ENDIF
	S" Mark I Manning IV"					\nSEARCH IF  2DROP CR  ." *Manning IV PLOOKED* "  TRUE EXIT  ENDIF
	S" maslicke@oakland.edu (Mark Slicker)"			\nSEARCH IF  2DROP CR  ." *maslicke PLOOKED* "    TRUE EXIT  ENDIF
	S~ "Michael L.Gassanenko" <m_l_g3@yahoo.com>~ 		\nSEARCH IF  2DROP CR  ." *mlg PLOOKED* "         TRUE EXIT  ENDIF
	S~ Michael L Gassanenko <m_l_g3@yahoo.com>~		\nSEARCH IF  2DROP CR  ." *mlg2 PLOOKED* "        TRUE EXIT  ENDIF
	S~ m_l_g3@yahoo.com (Michael L Gassanenko)~		\nSEARCH IF  2DROP CR  ." *mlg PLOOKED* "         TRUE EXIT  ENDIF
	S" mlg <m_l_g3@yahoo.com>"				\nSEARCH IF  2DROP CR  ." *mlg PLOOKED* "         TRUE EXIT  ENDIF
	S" Michael L Gassanenko <mlg@forth.org>"		\nSEARCH IF  2DROP CR  ." *mlg3 PLOOKED* "        TRUE EXIT  ENDIF
	S" Jerry Avins <jya@ieee.org>"		 		\nSEARCH IF  2DROP CR  ." *Avins PLOOKED* "       TRUE EXIT  ENDIF
	S" Andreas Klimas <klimas@klimas-consulting.com>" 	\nSEARCH IF  2DROP CR  ." *Klimas PLOOKED* "      TRUE EXIT  ENDIF
	S~ "Airy R. Bean" <airy.r.bean@lycos.co.uk>~		\nSEARCH IF  2DROP CR  ." *Airy Bean PLOOKED* "   TRUE EXIT  ENDIF
	2DROP FALSE ; IS KOOK?

-- ------------------------------------------------------------------------------------------
: get^ ( -- u ) 
	markerfile COUNT R/W BIN OPEN-FILE ?FILE >S
	S FILE-SIZE ?FILE DROP SLOT CELLS CELL+
	U< IF 0
	 ELSE SLOT CELLS U>D S REPOSITION-FILE ?FILE
	      newsmarker =CELL S READ-FILE ?FILE DROP  newsmarker @
	ENDIF
	S> CLOSE-FILE DROP ; PRIVATE

: put^ ( u -- ) 
	markerfile COUNT R/W BIN OPEN-FILE ?FILE >S
	SLOT CELLS U>D S REPOSITION-FILE ?FILE
	newsmarker !  
	newsmarker =CELL S WRITE-FILE ?FILE  S> CLOSE-FILE DROP ; PRIVATE

: GOBACK ( +u -- )
	ABS NEGATE 
	debug? @ IF  CR ." Backing up " DUP DEC. ." articles." ENDIF
	get^ + put^ ;

: open-newsfile ( -- )
	NEWSFILE COUNT R/W BIN OPEN-FILE ?FILE TO file
	file FILE-SIZE ?FILE 	( move to eof )
	file REPOSITION-FILE ?FILE ; PRIVATE

: close-newsfile ( -- )	file CLOSE-FILE DROP ; PRIVATE

: nntp-init ( -- )
	server COUNT IPPORT_NNTP $OPEN-I/O [sock] 
	0 SET-SOCKET-TIMEOUT  EAT-ALL ; PRIVATE

: nntp-exit ( -- ) S" QUIT" cmd  SCLOSE-I/O [sock] ; PRIVATE

: fetch ( c-addr u -- first last #num ) 
	1 1 0 LOCALS| #articles first-article last-article |
	S" GROUP " 2SWAP $+ cmd  
	response$ #resp
	$>num TO #articles  
	$>num TO first-article  
	$>num TO last-article 2DROP
	debug? @ IF  CR #articles DEC. ." articles, from " first-article DEC. 
			." to " last-article 0 .R
		        ." , read pointer = " first-article get^ MAX DEC.
	      ENDIF
	first-article get^ MAX  last-article   2DUP SWAP - 1+  0 MAX
	DUP IF  CR ." Retrieving " DUP DEC. ." article" DUP ?s ."  ... " ENDIF ; PRIVATE

: ask-for-it? ( u -- TRUE=error ) S" ARTICLE " ROT (0DEC.R) $+ cmd? ; PRIVATE

: (store) ( first last -- #count )
	0 LOCAL #count
	DUP >S ( save last )
	   1+ SWAP ?DO  I ask-for-it? S" NEXT ARTICLE" ?store-it 
			0= IF  1 +TO #count  ENDIF 
		  LOOP
	S> 1+ put^  #count ; PRIVATE

: store-group ( -- )    
	SUSPENDED? ?EXIT
	GROUPNAME COUNT fetch ( -- first last #num )
	0= IF  2DROP CR ." No new news in " GROUPNAME .$ EXIT  ENDIF
	open-newsfile
	 ( first last -- ) 
	 ['] (store) CATCH ?DUP IF close-newsfile THROW ENDIF
	close-newsfile 
	GROUPNAME .$ ." 's " DUP DEC. ." new article" ?s ."  stored." ; PRIVATE

: store-news ( -- ) 
	groupchain EXECUTE 
	BEGIN  
	  store-group 
	  NEXTGROUP ?DUP 
	WHILE  
	  EXECUTE
	REPEAT ; PRIVATE

: NEWS	( -- ) nntp-init store-news nntp-exit ;

\ Command string		  -- Help string -- Function -- Function key
  $" EDIT idata/clfnews.dat "	      $" Forth"	   {execute}	TO   fkey7
  $" EDIT idata/declf.dat "	      $" DeForth"  {execute}	TO   fkey8
  $" EDIT idata/cfortran.dat "	      $" Fortran"  {execute}	TO   fkey9
  $" EDIT idata/scinews.dat "	      $" Numeric"  {execute}	TO   fkey10

:ABOUT	CR ." Usage: NEWS      -- get new news" 
	CR ."        u GOBACK  -- backup some articles"
	CR ."    name <u> put^ -- preset highwater marker of newsgroup ( clf dcl sci cfn )"
	CR ."        {F7}      -- comp.lang.forth"
	CR ."        {F8}      -- de.comp.lang.forth"
	CR ."        {F9}      -- comp.lang.fortran"
	CR ."        {F10}     -- sci.math.num-analysis" ;

	.ABOUT -news CR
	DEPRIVE
\	NEEDS -geturl  CR .( my counter was: ) TAIL CR .( my counter now: ) MYCOUNTER TYPE UPDATE-LOG  -geturl
	NEWS

					(* End of Source *)