10	SUB WWWCGI
	%TITLE "WWWCGI"
	%IDENT "X0.28"
	!
	! Routine that handles CGI for BQTWEB
	! (c) 2012 by Johnny Billquist
	!
	! X0.0	18-Apr-2012	Johnny Billquist
	!	Initial coding
	!
	! X0.1	5-Jun-2012	Johnny Billquist
	!	Added CMD variable
	!
	! X0.2	30-Dec-2012	Johnny Billquist
	!	Add cleanup if error
	!
	! X0.3	23-Mar-2014	Johnny Billquist
	!	Changed timeouts
	!
	! X0.4	29-Jul-2014	Johnny Billquist
	!	Change code slightly in preparation for making it
	!	possible for CGI scripts to return other than 200 code.
	!
	! X0.5	30-Nov-2014	Johnny Billquist
	!	Add PUSH before trying to read data, to make sure
	!	all send data is out.
	!
	! X0.6	19-Jul-2015	Johnny Billquist
	!	Bugfix. 0 length data from a subprocess should not
	!	be passed on.
	!
	! X0.7	20-Mar-2016	Johnny Billquist
	!	Bugfix. We need to set default to the right dir,
	!	before running.
	!
	! X0.8	20-Mar-2016	Johnny Billquist
	!	Added handling of multipart form data.
	!
	! X0.9	22-Mar-2016	Johnny Billquist
	!	Reworked how POST works. It now creates a file, where
	!	all data is stored, and then that filename is passed
	!	to the CGI program. Also lots of small tweaks and
	!	bugfixes.
	!
	! X0.10	23-Mar-2016	Johnny Billquist
	!	Add cleanup of forms files if needed.
	!
	! X0.11	30-Apr-2016	Johnny Billquist
	!	Corrected what QUERY_STRING contains.
	!
	! X0.12	13-May-2016	Johnny Billquist
	!	Added handling of lost connection.
	!
	! X0.13	26-Sep-2016	Johnny Billquist
	!	Added handling of errors when running commands.
	!
	! X0.14	28-Sep-2016	Johnny Billquist
	!	Correct code to not defined QUERY_STRING if
	!	string length is zero.
	!
	! X0.15	2-Dec-2016	Johnny Billquist
	!	Changed reading to use RECV instead of LINPUT.
	!
	! X0.16	3-Dec-2017	Johnny Billquist
	!	Changed code to first process all HTTP input parts,
	!	before creating subprocess and run things.
	!
	! X0.17	11-Dec-2017	Johnny Billquist
	!	Add pushing of data for CGI. We don't so much want high
	!	throughput as a somewhat interactive effect when running
	!	CGI programs.
	!	Added better handling of lost connect, causing an error
	!	to propagate back to called for further handling and logging.
	!
	! X0.18	24-Jan-2018	Johnny Billquist
	!	Adapted to updated subp module.
	!
	! X0.19	25-Feb-2018	Johnny Billquist
	!	Added error counter and abort if count is excessive.
	!
	! X0.20 22-Aug-2018	Johnny Billquist
	!	Added clearing of VTN once terminal is closed.
	!
	! X0.21	8-Oct-2018	Johnny Billquist
	!	Added the capability for CGI programs to return different
	!	 status
	!
	! X0.22	24-Jan-2019	Johnny Billquist
	!	Cut MAXL down to 180 from 200. 200 cause the final
	!	length of DFL commands to potentially become too
	!	long, crashing the whole system.
	!
	! X0.23	24-Sep-2019	Johnny Billquist
	!	Change code to always try to delete .FDA file after
	!	run.
	!
	! X0.24	5-Mar-2020	Johnny Billquist
	!	Bugfix. In case of errors, we might get to the cleanup
	!	stage before we even created a subprocess. In that
	!	situation, we should not try to clean up the subprocess
	!	either.
	!
	! X0.25	25-Jun-2020	Johnny Billquist
	!	If text lines comes from CGI, which starts with a CR,
	!	not followed by an LF, then we strip the CR. We assume
	!	it's just the standard RSX pre-CR feature...
	!
	! X0.26	14-Aug-2020	Johnny Billquist
	!	Cleared F.LOG once we have started generating header.
	!	This means we can get one new log entry if we get a fail
	!	while serving the page.
	!
	! X0.27 1-Oct-2020	Johnny Billquist
	!	Bugfix. Error handler could loop forever.
	!
	! X0.28	24-Sep-2021	Johnny Billquist
	!	Bugfix. If cleanup tried to open a file that the cgi
	!	code had already deleted, we ended up with an additional
	!	spurious error which made the whole program exit in a
	!	bad way.

	%INCLUDE "WWW.INC"
	%INCLUDE "LB:[1,1]BQTLIB.B2S"

	DECLARE WORD VTN,LN,X,I,J,S,HI,HJ,DI,TI,TJ
	DECLARE STRING BUF,B2,B3,C
	DECLARE WORD CONSTANT MAXL=178
	DECLARE WORD F.HDR, F.STS, F.URLENC, F.MULTI, F.TXT, F.CON, F.FIL
	DECLARE STRING C.DATA, BOUNDARY, CONTEXT
	DECLARE STRING OFIL, FORMN, CFIL, OFNAM

	! Function to convert a HEX string to a character.
	DEF STRING DEHEX(STRING H)
		H=EDIT$(H,32)
		HI=INSTR(1,"0123456789ABCDEF",LEFT$(H,1))-1
		HJ=INSTR(1,"0123456789ABCDEF",RIGHT$(H,2))-1
		DEHEX=CHR$(HI*16+HJ)
	END DEF

	! Function to decide URL-encoding
	DEF STRING DECODE(STRING S)
		R_loop1:
		WHILE 1
			DI = INSTR(1,S,"+")
			EXIT R_loop1 IF DI=0
			S=LEFT$(S,DI-1)+" "+RIGHT$(S,DI+1)
		NEXT

		R_loop2:
		WHILE 1
			DI = INSTR(DI+1,S,"%")
			EXIT R_loop2 IF DI=0
			S=LEFT$(S,DI-1)+			&
				DEHEX(MID$(S,DI+1,2))+	&
				RIGHT$(S,DI+3)
		NEXT
		DECODE = S
	END DEF

	! Create a string for random filename.
	DEF STRING RNAM
		TI = RND*10000
		TJ = RND*10000
		RNAM = FORMAT$(TI,"<0>###") + FORMAT$(TJ,"<0>###")
	END DEF
		
	! Trim strings. Remove leading LF and add at the end.
	DEF STRING TRM(STRING IN)
		IF LEFT$(IN,1)=LF THEN
			IN = RIGHT$(IN,2)
			IN = IN+LF IF RIGHT$(IN,LEN(IN))=CR
		END IF
		TRM = IN
	END DEF

	! Parse a line for a status value from the CGI code.
	DEF WORD CSTAT(STRING S)
		EXIT DEF 0 IF LEN(S)<5
		FOR I=1 TO 3
			EXIT DEF 0 IF INSTR(1,"0123456789", MID(S,I,1))=0
		NEXT I
		STATVAL = VAL(LEFT$(S,3))
		STATTXT = EDIT$(RIGHT$(S,4),4+8)
	END DEF 1

	! Read a line from the subprocess, and pass it on.
	DEF WORD RDSUB
		LN = GETLIN(CMDFIL,BUF)
		B2 = TRM(LEFT$(BUF,LN))
		B2 = RIGHT$(B2,2) IF LEFT$(B2,1) = CR AND MID$(B2,2,1) <> LF
		IF (LEN(B2) > 0) THEN
			IF F.HDR THEN
				IF F.STS THEN
					S = CSTAT(B2)
					CALL WWWHDR(0)
					PRINT #WWWFIL,B2; UNLESS S
					F.STS = 0
					F.LOG = 0
				ELSE
					PRINT #WWWFIL,B2;
					F.HDR=0 IF B2=CR+LF
				END IF
			ELSE
				CALL CHUNK(WWWFIL,B2)
			END IF
			!CALL PUSH(WWWFIL)
		END IF
	END DEF

	! Execute a command in a subprocess and wait for completion.
	DEF WORD DOCMD(WORD VTL, WORD LUN, STRING C)
		CALL CMD(VTL,C)
		D_Loop:
		WHILE 1
			S = WAITS
			IF S AND SUBP_WRITE THEN
				LN = GETLIN(LUN,BUF)
				B2 = EDIT$(LEFT$(BUF,LN),4+8)
				PRINT "WWW - CGI subprocess error: ";B2
				PRINT "WWW - Command was ";C
			END IF
			CALL PUTEOF(LUN) IF S AND SUBP_READ
			EXIT D_Loop IF S AND SUBP_EXIT
		NEXT
		CAUSE ERROR 253 IF S AND SUBP_ERR
	END DEF

	! Replace quotes with doubles in string.
	DEF STRING QUO2(STRING S)
		TI = 1
		WHILE 1
			TI = INSTR(TI,S,'"')
			IF TI=0 THEN
				QUO2 = S
				EXIT DEF
			END IF
			S = LEFT$(S,TI)+RIGHT$(S,TI)
			TI = TI+2
		NEXT
	END DEF

	! Define a logical name in a subprocess.
	DEF WORD DFL(WORD VTL,WORD LUN,STRING NAM,STRING EQU)
		B2 = TRM$(EQU)
		B2 = LEFT$(B2,MAXL) IF LEN(B2) > MAXL
		B3 = QUO2(B2)
		X = DOCMD(VTL,LUN,'DFL "'+B3+'"='+NAM)
	END DEF

	!
	! Actual CGI handler starts here.
	!

	ON ERROR GOTO Hell

	BUF = SPACE$(512)
	VTN = 0
	F.HDR = 1	! Start in state that we are producing header.
	F.STS = 1	! Flag that we haven't even started on header yet.
	COMPARE = 0	! For CGI, we do not support the conditional header
			! functions.
	F.CON = 1	! Start out marking that we are connected.
	ECNT = 0	! Reset error count

	I = INSTR(1,DIR,"]")
	I = INSTR(1,DIR,":") IF I=0
	DIR = LEFT$(DIR,I) IF I>0

	C.DATA=EDIT$(CTYP,4+8+16+32+128)	! Get content in easy to digest
						! form.

	I = INSTR(1,C.DATA,";")		! Isolate content part.
	I = LEN(C.DATA)+1 IF I=0
	C.DATA = LEFT$(C.DATA,I-1)

	! And figure out what content is.
	SELECT C.DATA
		CASE "APPLICATION/X-WWW-FORM-URLENCODED"
			F.URLENC=1
		CASE "MULTIPART/FORM-DATA"
			IF F.POST=0 THEN
				CALL WWWERR(405,"Method not allowed", &
					"Allow: POST", &
					"Content is multipart but not a POST")
				GOTO DONE
			END IF
			F.MULTI=1
		CASE ELSE
			! This should only happen on GET...
			IF F.POST THEN
				CALL WWWERR(405,"Method not allowed", &
					"Allow: GET,HEAD", &
					"Unknown content: "+C.DATA)
				GOTO DONE
			END IF
	END SELECT

	IF F.POST AND CLEN=0 THEN
		CALL WWWERR(400, "Bad request", "", &
			"Multipart POST with no content length.")
		GOTO DONE
	END IF

	! Now start working...
	!
	! The first part is reading in all information from
	! the client, and store it in appropriate places.
	!
	IF F.MULTI THEN
		! Multipart message. We need to found out the boundary.
		BOUNDARY=EDIT$(CTYP,4+8+16+32+128)
		I = INSTR(1, BOUNDARY, "BOUNDARY=")
		IF I=0 THEN
			CALL WWWERR(400, "Bad request", "", &
				"Multipart message with no boundary given")
			GOTO DONE
		END IF

		J = INSTR(I, BOUNDARY, ",")
		J = LEN(BOUNDARY)+1 IF J=0

		BOUNDARY = SEG$(BOUNDARY, I+9, J-1)

		! We have it. Now we need to create a context for the
		! MIME processor.

		CONTEXT = SPACE$(512+LEN(BOUNDARY)*2+32)
		CALL MIME(WWWFIL,CONTEXT,BOUNDARY,CLEN)

		CALL BEPRIV(UIC)
		CFIL = TRM$(DIR)+"C"+RNAM+".FDA"
		OPEN CFIL FOR OUTPUT AS FILE HTMFIL
		Mime_loop:
		WHILE 1
			F.TXT = 1
			OFNAM = ""
			FORMN = ""
			Mime_read:
			WHILE 1
				X = GMIME(1,CONTEXT,BUF,LN,510)
				EXIT Mime_loop IF X=2
				B2 = LEFT$(BUF,LN)
				C.DATA = EDIT$(B2,4+8+16+32+128+256)
				EXIT Mime_read IF LN=0
				F.TXT=0 IF LEFT$(C.DATA,13) = "CONTENT-TYPE:" &
					AND INSTR(1,C.DATA,"TEXT") = 0
				I = INSTR(1,C.DATA,'NAME="')
				IF I>0 THEN
					J = INSTR(I+6,C.DATA,'"')
					FORMN = SEG$(C.DATA,I+6,J-1) IF J>0
				END IF
				I = INSTR(1,C.DATA,'FILENAME="')
				IF I>0 THEN
					J = INSTR(I+10,C.DATA,'"')
					OFNAM = SEG$(C.DATA,I+10,J-1) IF J>0
				END IF
			NEXT
			OFIL = TRM$(DIR)+"F"+RNAM+".FDA"
			PRINT #HTMFIL,"--"
			PRINT #HTMFIL,"NAME=";EDIT$(FORMN,32)
			PRINT #HTMFIL,"FILE=";OFIL
			PRINT #HTMFIL,"TYPE=TEXT" IF F.TXT
			PRINT #HTMFIL,"TYPE=BINARY" UNLESS F.TXT
			PRINT #HTMFIL,"ORIGINAL=";OFNAM
			IF F.TXT THEN
				OPEN OFIL FOR OUTPUT AS FILE #TMPFIL
			ELSE
				OPEN OFIL FOR OUTPUT AS FILE #TMPFIL, &
					ORGANIZATION SEQUENTIAL FIXED, &
					RECORDTYPE NONE, RECORDSIZE 512
			END IF
			Mime_data:
			WHILE 1
				X = GMIME(F.TXT,CONTEXT,BUF,LN,512)
				EXIT Mime_data IF X=1
				EXIT Mime_loop IF X=2
				IF F.TXT THEN
					PRINT #TMPFIL,LEFT$(BUF,LN)
				ELSE
					LSET BUF = LEFT$(BUF,LN) + &
						STRING$(512-LN,0) IF LN<512
					MOVE TO #TMPFIL, BUF
					PUT #TMPFIL
				END IF
			NEXT
			CLOSE #TMPFIL
		NEXT
		PRINT #HTMFIL,"--"
		CLOSE #HTMFIL
		CLEN = 0
		GOTO Subproc
	END IF

	IF F.POST THEN
		I = CLEN
		CALL STMO(WWWFIL,TMO)		! Timeout.
		CALL SCHR(WWWFIL,A"&"W,I)	! '&' separator and max I char.

		CALL BEPRIV(UIC)
		CFIL = TRM$(DIR)+"C"+RNAM+".FDA"
		OPEN CFIL FOR OUTPUT AS FILE HTMFIL
		Rq_Loop:
		WHILE 1
			B2 = RECV(WWWFIL,512)
			CLEN = CLEN-LEN(B2)-1
			I = INSTR(1,B2,"=")
			I = INSTR(1,B2,":") IF I=0
			C.DATA = RIGHT$(B2,I+1)
			B2 = EDIT$(LEFT$(B2,I-1),32)
			PRINT #HTMFIL,"--"
			PRINT #HTMFIL,"NAME=";DECODE(B2)
			PRINT #HTMFIL,"VALUE=";DECODE(C.DATA)
			EXIT Rq_loop IF CLEN<1
		NEXT
		PRINT #HTMFIL,"--"
		CLOSE #HTMFIL
	END IF

	!
	! At this point, we are done processing data from the post.
	! We now only have to pass the result from the subprocess
	! back to the web client.
	!
	Subproc:

	VTN=CRSUB(CMDFIL,UIC)	! Create subprocess.

	IF VTN=0 THEN
		CALL WWWERR(500,"Internal error", "", &
			"Failed to create subprocess.")
		GOTO DONE
	END IF

	! Next we define a bunch of logical names.
	!
	! HTTP_URL should be the URL up to, but not including '?'
	! QUERY_STRING should be anything between '?' and '#'
	! HTTP_METHON "GET" or "POST"
	! HTTP_UAG should be the user agent
	! HTTP_HOST
	! REMOTE_ADDRESS
	! REMOTE_HOST
	! REMOTE_PORT
	! HTTP_CONTENT
	! HTTP_REFERRER
	! HTTP_COOKIE
	!
	I = INSTR(1,URI,"?")
	J = I
	J = LEN(URI)+1 IF J=0
	X = DFL(VTN,CMDFIL,"HTTP_URL",LEFT$(URI,J-1))
	IF I>0 THEN
		J = INSTR(I,URI,"#")
		J = LEN(URI)+1 IF J=0
		X = DFL(VTN,CMDFIL,"QUERY_STRING",SEG$(URI,I+1,J-1)) UNLESS I+1>=J-1
	END IF

	X = DFL(VTN,CMDFIL,"HTTP_METHOD",FUN)
	X = DFL(VTN,CMDFIL,"HTTP_UAG",UAG) UNLESS UAG=""
	X = DFL(VTN,CMDFIL,"HTTP_HOST",HOST) UNLESS HOST=""
	I = INSTR(1,REMOTE,":")
	X = DFL(VTN,CMDFIL,"REMOTE_ADDR",LEFT$(REMOTE,I-1))
	X = DFL(VTN,CMDFIL,"REMOTE_HOST",IP2HOS(EP,RES_NADR))
	X = DFL(VTN,CMDFIL,"REMOTE_PORT",RIGHT$(REMOTE,I+1))
	I = INSTR(1,CTYP,";")-1
	I = LEN(TRM$(CTYP)) IF I<1
	X = DFL(VTN,CMDFIL,"HTTP_CONTENT",LEFT$(CTYP,I-1)) UNLESS I<1
	X = DFL(VTN,CMDFIL,"HTTP_REFERER",REFER) UNLESS REFER=""
	B2 = TRM$(COOKIE)
	IF B2<>"" AND LEN(B2)<MAXL THEN
		X = DFL(VTN,CMDFIL,"HTTP_COOKIE",B2)
	END IF

	! Next we change the default directory.
	X = DOCMD(VTN,CMDFIL,"SET /NAMED")
	X = DOCMD(VTN,CMDFIL,"SET /DEF="+TRM$(DIR))

	! And finally we run the CGI program.
	CALL CMD(VTN,TRM$(FNAM))

	F.FIL = 1 IF CFIL<>""

	W_LOOP:
	WHILE 1
		S = WAITS		! Wait for action in subprocess.
		X = RDSUB IF S AND SUBP_WRITE	! Subprocess tries to write data.
		IF S AND SUBP_READ THEN
					! Subprocess tries to read data.
			IF F.FIL THEN
				CALL PUTLIN(CMDFIL,CFIL)
				F.FIL = 0
			ELSE
				CALL PUTEOF(CMDFIL)
			END IF
		END IF
		EXIT W_Loop IF S AND SUBP_EXIT	! Subprocess exited.
	NEXT
	CAUSE ERROR 253 IF S AND SUBP_ERR

	CMERR:
	IF F.CHUNK THEN
		PRINT #WWWFIL,"0"
		PRINT #WWWFIL
	END IF

	WHILE CLEN > 0
		B2 = RECV(WWWFIL,512)
		CLEN = CLEN-LEN(B2)-1
	NEXT

	DONE:
	End_loop:
	IF VTN <> 0 THEN
		WHILE 1
			S = WAITS
			LN = GETLIN(CMDFIL,BUF) IF S AND SUBP_WRITE
			CALL PUTEOF(CMDFIL) IF S AND SUBP_READ
			EXIT End_loop IF S AND SUBP_EXIT
		NEXT
		CAUSE ERROR 253 IF S AND SUBP_ERR
	END IF

	IF F.CON THEN
		CALL STMO(WWWFIL,3600)		! Back to no timeout.
		CALL SCHR(WWWFIL,0,0)	! Reset special input handling.
	END IF

	ABRT:
	!
	! This is the ultimate cleanup place.
	!
	CALL DLSUB(VTN) IF VTN>0
	VTN = 0

	!
	! If CFIL contains the filename, that means
	! we have forms information we need to clean up.
	!
	IF CFIL <> "" THEN
		OPEN CFIL FOR INPUT AS HTMFIL
		WHILE 1
			LINPUT #HTMFIL,B2
			IF LEFT$(B2,5)="FILE=" THEN
				OFIL=RIGHT$(B2,6)
				KILL OFIL
			END IF
		NEXT
	END IF

	DONE2:
	ON ERROR GO BACK

	CLOSE #HTMFIL
	KILL CFIL IF CFIL<> ""
	CFIL = ""

	IF F.CON = 0 THEN
		CAUSE ERROR 14
	END IF

	EXIT SUB

	DONE3:
	ON ERROR GO BACK
	CAUSE ERROR 14

	Hell:
	!PRINT "WWW - CGI error:";ERR;F.CON
	ECNT = ECNT+1

	RESUME DONE3 IF ECNT>10

	RESUME ABRT UNLESS F.CON

	SELECT ERR
		CASE 5		! File not found. CGI deleted forms file?
			CFIL = ""
			RESUME DONE2
		CASE 11		! EOF can only mean one thing.
			RESUME DONE2
		CASE 14		! I/O failure means network write error
			F.KAF=0
			F.CON=0
			RESUME DONE
		CASE ELSE
			F.KAF=0
			RESUME DONE
	END SELECT
	
	END SUB