\ <Forthmacs$Dir>.risc_os.server
\ mailserver V. 1.2 hs 25.01.96

needs fmail risc_os/mailing.fth

only forth also definitions  system also  hidden also

256 buffer: user-name
256 buffer: user-root
256 buffer: user-path

variable opened?
variable silent?
variable thislog

: init-vars	(s -- )
	thislog off	silent? off	opened?	off	ofd off
	user-name off	user-root off	user-path off ;
	init-vars

: job		(s str -- )	"cli drop ;
: >tab		(s -- )		#out @ 12 > if cr then 12 to-column ;
: u_pwd		(s -- )		." Path: root" (pwd count user-root
				count nip dup >r - swap r> + swap type ;
: .err		(s -- )		>tab ." ERROR: " ;
: path?		(s str -- str )	getenv ?dup ?exit
				.err ." missing env variable" ". cr bye ;
: ppath		(s -- str )	p" server_publicpath"	path? ;
: upath		(s -- str )     user-path dup c@ ?exit
				.err ." no user path available " user-path ". cr bye ;
: list		(s -- str )	p" server_list"		path? ;
: zip		(s -- str )	p" server_zip"		path? ;
: .app		(s -- )		??cr ." RiscOS Forthmacs mail-server v1.2"
				  cr ."    (c) Hanno Schwalm 1995/96" cr ;
: .server	(s -- )		p" server_info" getenv ?dup if ". then ;
: sending-ok?	(s str -- f )	attributes 1 = swap b# 10000 and 0<> and ;
: illegal?	(s str -- f )
	false swap count bounds
	?do	i c@ >r
		r@ [char] ^ =		r@ [char] $ = or	r@ [char] % = or
		r@ [char] < = or	r> [char] : = or
		if drop true leave then
	loop ;
: authorized?	(s -- f )
	user-name false locals| flag name |
	list read fopen ?dup 0= if .err ." No userlist found" cr flag exit then
	input-file @ >r input-file !
	begin	blword eof? 0=
	while	name "= if blword user-path "copy  true to flag then
		postpone \
	repeat
	input-file @ fclose  r> input-file ! flag ;
: set-userroot	(s -- )
	authorized? if upath else ppath then (cd drop  (pwd user-root "copy ;
: server-interpret-do-undefined	(s str -- )
	>tab ." ??  " ". space get-tail ". cr ;
: mail-spool	(s -- )
	user-name count lower
	p" <server_spool>"		crlf->lf
	p" set server_xuid <UUCP_uid>"	job
	p" set UUCP_uid <server_uid>"	job
	p" <server_spool>" user-name	(fmail
	if .err ." in smail" then
	p" wipe <server_spool> ~C~V"	job
	p" set UUCP_uid <server_xuid>"	job
	p" unset server_xuid"		job cr ;
: mail-logfile	(s -- )
	silent? @ ?exit
	ofd @ dup ftell locals| logend xofd |
	p" <server_spool>" new-file  ofd @ 0=
	if xofd ofd ! .err ." can't mail log" cr  exit then
	." To: " user-name ". cr
	." Subject: logfile from " .server cr cr
	.app cr
	logend  thislog @ dup xofd fseek
	- 0 ?do xofd fgetc emit loop  ofd @ fclose
	xofd ofd !
	>tab ." sending logfile to " user-name ". cr
	mail-spool ;

: unset-env	(s -- )
	p" Unset server_list"		job
	p" Unset server_logfile"	job
	p" Unset server_spool"		job
	p" Unset server_zip"		job
	p" Unset server_help"		job ;
: (bye		(s -- )
	cr ." -----------------" cr ofd @ fclose  unset-env (bye ;
: set-env	(s --)
	p" Set server_list    <server_dir>.list"	job
	p" Set server_logfile <server_dir>.log"		job
	p" Set server_spool   <server_dir>.spool"	job
	p" Set server_zip     <server_dir>.zip"		job
	p" Set server_help    <server_dir>.help"	job
	['] server-interpret-do-undefined is do-undefined
	['] bye is status
	['] (bye is bye ;

: mail-file	(s str -- )
	astring astring locals| cline aline fname |
	p" gzip -q5 < " cline "copy  fname cline "cat  p"  > " cline "cat
	zip cline "cat  cline 				"shell drop
	p" uue " cline "copy  zip cline "cat  cline	"shell drop
	p" wipe <server_zip> ~C~V" 			job
	p" <server_zip>_uue" read-open
	begin	aline ifd @ fgetline
	while	dup char+ p" begin" count compare 0=
		if 0 swap count bounds
		   do i c@ bl <= if 1+ then i c@ emit dup 2 = ?leave
		   loop drop fname ".
		else ".
		then cr
	repeat	ifd @ fclose
	p" wipe <server_zip>_uue ~C~V" job ;

vocabulary server-commands  server-commands definitions

: silent (s -- )
	silent? on  get-tail drop ;
: open  (s -- )
	opened? @ if p" open" server-interpret-do-undefined exit then
	cr ofd @ ftell thislog !
	." from" >tab user-name ". authorized?
	if ."  - registered user" then cr
	set-userroot  opened? on
	." open" >tab p" UUCP_domain" getenv ". cr ;
: quit	(s -- )
	opened? @ 0= if p" quit" server-interpret-do-undefined exit then
	." quit" cr
	mail-logfile ;
: from	(s -- )
	opened? @ if p" From " server-interpret-do-undefined exit then
	." From" >tab blword dup ". user-name "copy ;

: reply-to:	(s -- )
	opened? @ 0= if p" Reply-to: " server-interpret-do-undefined exit then
	." Reply-to:" >tab blword dup ". user-name "copy
	authorized? if ."  - registered user" then cr
	set-userroot ;
: reply-to reply-to: ;
: subject:	(s -- )
	blword astring "move astring astring ofd @
	locals| xofd aline cline subj |
	get-tail drop
	subj char+  p" help" count compare 0=
	if	." help" >tab user-name ".  >tab .today .now cr
		p" <server_spool>" new-file ofd @ 0=
		if xofd ofd !  .err ." can't open spoolfile" cr exit then
		." To: " user-name ". cr
		." Subject: help from " .server cr cr
		p" <server_help>" read-open
		begin aline ifd @ fgetline while ". cr repeat
		ifd @ fclose  ofd @ fclose  xofd ofd !
		mail-spool
	then ;
: ls	(s -- )
	user-name c@ 0= if p" ls" server-interpret-do-undefined exit then
	astring astring ofd @ locals| xofd mask cline |
	p" info " cline "copy
	cr ." ls" >tab get-tail mask "copy
	mask c@ if mask else p" *" then dup ". cr  cline "cat
	mask illegal? if .err ." illegal ls mask " mask ". >tab u_pwd cr exit then
	>tab u_pwd cr 
	p" <server_spool>" new-file  ofd @ 0=
	if xofd ofd !  .err ." can't open spoolfile" cr exit then
	." To: " user-name ". cr
	." Subject: " .server ."  ls " mask ". 26 to-column ." <" u_pwd ." >" cr cr
	.app cr
	ofd @ fclose  xofd ofd !
	>tab ." sending mail "
	p" { >> <server_spool> }" cline "cat	 cline job
	mail-spool ;

: get	(s -- )
	user-name c@ 0= if p" get" server-interpret-do-undefined exit then
	." get "
	astring ofd @ locals| xofd fname |
	blword fname "copy get-tail drop  >tab fname ". cr  >tab u_pwd cr
	fname illegal? if .err ." illegal fname " fname ". cr exit then
	p" <server_spool>" new-file  ofd @ 0=
	if xofd ofd !  .err ." can't open spoolfile" cr exit then
	." To: " user-name ". cr
	." Subject: " .server ."  get " fname ". ." _gz"
	26 to-column ." <" u_pwd ." >" cr cr
	.app cr
	fname sending-ok? dup
	if fname mail-file else .err fname ". ."  not available" cr then
	ofd @ fclose  xofd ofd !
	if >tab ." sending mail" else .err fname ". ."  not available" cr then
	mail-spool ;
	
: cd	(s -- )
	user-name c@ 0= if p" cd" server-interpret-do-undefined exit then
	(pwd astring "move locals| oldpath |
	." cd" >tab  get-tail dup (cd drop ".
	(pwd char+  user-root count compare
	if .err ." can't change directory" oldpath (cd drop then
	>tab u_pwd cr ;

forth definitions
: serve	(s -- )
	sys-commandline
	astring "move locals| fname |
	only forth server-commands definitions seal
	caps on
	set-env
	p" <server_logfile>" append-open file-output
	ofd @ 0= ?exit
	cr cr >tab .server  >tab .today .now cr cr
	fname file-exists? 0=
	if >tab .err ." with file " fname ". exit then
	fname load-file
	only forth also definitions ;
only forth also definitions
' noop is load-hook
' noop is title
: (cold-hook
	(cold-hook serve bye ;
	' (cold-hook is cold-hook
decimal dispose warning on
