;; These are routines to help writing W3 scripts server-side via the CGI
;; common interface in Klone

;;  The CERN 3.0 server sets for instance these env varibales for scripts:
;;  SERVER_SOFTWARE = CERN/3.0
;;  SERVER_NAME = colas.inria.fr
;;  SERVER_PORT = 80
;;  GATEWAY_INTERFACE = CGI/1.1
;;  SERVER_PROTOCOL = HTTP/1.0
;;  REQUEST_METHOD = POST
;;  PATH_INFO = 
;;  PATH_TRANSLATED = 
;;  QUERY_STRING = 
;;  SCRIPT_NAME = /cgi-bin/essai
;;  REMOTE_HOST = localhost
;;  REMOTE_ADDR = 127.0.0.1
;;  AUTH_TYPE = 
;;  REMOTE_USER = 
;;  REMOTE_IDENT = 
;;  CONTENT_TYPE = application/x-www-form-urlencoded
;;  CONTENT_LENGTH = 23
;;  REFERER_URL = http://www.inria.fr/essais/a_form.html
;;  HTTP_ACCEPT = */*, image/gif, image/x-xbitmap, image/jpeg
;;  HTTP_USER_AGENT = Mozilla/1.1N (X11; I; Linux 1.2.0 i586)
;;  HTTP_REFERER = http://www.inria.fr/essais/a_form.html

;; and NCSA 1.4.2:
;;SERVER_SOFTWARE = NCSA/1.4.2
;;HTTP_PRAGMA = no-cache
;;PATH = /bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin
;;DOCUMENT_ROOT = /usr/local/etc/httpd/htdocs


;;AUTOLOAD: cgi:init
;;AUTODOC: cgi:init "initialize things for a WWW CGI script"
"(cgi:init [:error error-stream])

must be issued at the start of a Klone script launched via the CGI interface
to spawn external scripts from the WWW servers. All output to stdout will
build the page to be sent to the server, but the http ones will be build by
these commands.  You only have to build the html page (<TITLE>, <H1>, etc...)
Works for normal or nph- ones (No Parse Headers, headers are constructed
automatically by cgi:end.

Tou *MUST* call cgi:end at the end of the script or nothing will happen!

Defines the following global variables that you can use in your script:
  cgi:arguments     the p-list of form field names and values as strings
  cgi:script-name   the name of the script (relative URL)
  cgi:query-string  the value of QUERY_STRING, part after the ? in URL
  cgi:path-info     extra path after the script URL
  cgi:path-translated     whole URL (may not be significant)

keywords:
  :error  specifies what to do with output to the stderr. default is ignore,
          can be a string which should be filename where they will be appended
          or a stream (such as a pipe to an unix command, e.g. sendmail)
"
(defun cgi:init (&key ((error where-error)) &aux
    buffer
    (re-field (regcomp "[ \t\n\r&]*([^=\r\n&\\]+)=([^=\r\n&\\]*)"))
    (offset 0)
  )
  (:= cgi:is-a-NoParseHeader-script? 
    (match "[/][nN][pP][hH]-[^/]+$" (0 *arguments*)))
  (:= cgi:stdout *standard-output*)
  (:= cgi:stderr *standard-error*)
  (:= cgi:out-string (copy ""))
  (:= *standard-output* (open cgi:out-string :direction :output :type :string))
  (:= *standard-error* (if 
      (typep where-error String)
      (open where-error :direction :output :if-exists :append)
      (typep where-error Stream)
      where-error
      ;; nil
      (open "/dev/null" :direction :output)
  ))

  (:= cgi:query-string
    (html:unquote-values (html:decode_plus (getenv "QUERY_STRING")))
  )
  (:= cgi:path-info
    (html:unquote-values (html:decode_plus (getenv "PATH_INFO")))
  )
  (:= cgi:path-translated
    (html:unquote-values (html:decode_plus (getenv "PATH_TRANSLATED")))
  )
  (:= cgi:script-name
    (html:unquote-values (html:decode_plus (getenv "SCRIPT_NAME")))
  )

  (stream-mode *standard-input* :blocking ())
  (setq buffer "")
  (catch 'EOF (:= buffer (read-chars ())))
  (stream-mode *standard-input* :blocking t)
  
  (:= cgi:arguments (list))
  (while (regexec re-field buffer offset)
    (lappend cgi:arguments (html:unquote-values (regsub re-field 1)))
    (lappend cgi:arguments (html:unquote-values (html:decode_plus (regsub re-field 2))))
    (setq offset (1 (get re-field 0)))
  )
)

;;AUTOLOAD: cgi:end
;;AUTODOC: cgi:end "ends a WWW CGI script and send back data"
"(cgi:end [:location URL] [:validity time])
Ends a script beginning a cgi:init, sends back collected output to WWW client.

keywords:
  :location   can specify an URL, in this case no data is sent and the client 
              will go directly to the URL.
  :validity   normally the expiration date is set to now, you can specify here
              the actual amount in minutes
  :mimetype   contents-type: default: text/html, can be text/plain (or others)
"

(defun cgi:end (&key location (mimetype "text/html") (validity 0) &aux
  )
  (if location				;redirect to location
    (PF cgi:stdout "Location: %n0\n\n" location)
    (progn				;gives back the stdout itself
      (if cgi:is-a-NoParseHeader-script? 
	;; NPH- script
	(PF cgi:stdout "HTTP/1.0 200 Document follows
MIME-Version: 1.0
Server: CERN/3.0, Klone CGI script
Date: %1
Expires: %2
Content-Type: %4
Content-Length: %0\n\n%3"
	  (length cgi:out-string)
	  (html:date)
	  (html:date (+ (get-current-time) (* 60 validity)))
	  cgi:out-string
	  mimetype
	)
	;; normal script
	(PF cgi:stdout "Content-Type: text/html\n\n%0" cgi:out-string)
      )
  ))
  (flush cgi:stdout)
)


;;AUTOLOAD: html:date
;;AUTODOC: html:date "converts a klone date to the standard html form"
;;(html:date [date])
;;
;;given a date as a list of numbers or a number of seconds, returns a string
;;in the HTML format such as Saturday, 08-Jul-95 22:34:35 GMT
;;if no date given, gives current one.

(defun html:date (&optional d)
  (if					;converts to seconds
    (and (typep d List) (>= (length d) 7))
    (setq d (date-to-seconds d))

    (typep d Int)
    ()

    (setq d (get-current-time))
  )
  (incf d (- TIMEZONE-sec))		;GMT
  (setq d (seconds-to-date d))		;convert to list
  (+					;formats for html
    (get '("Sunday" "Monday" "Tuesday" "Wednesday"
	"Thursday" "Friday" "Saturday"
      ) (6 d)      
    )
    ", " (String (2 d)) "-"
    (subseq "JanFebMarAprMayJunJulAugSepOctNovDec" (* 3 (- (1 d) 1))
      (* 3 (1 d))
    )
    "-" (subseq (String (0 d)) 2) " "
    (String (3 d)) ":" (String (4 d)) ":" (String (5 d)) " GMT"
  )
)

;; (html:unquote-values string)
;; returns a new string with the forms %xx are expanded into the character of
;; hexadecimal code xx

(defun html:unquote-values (string &aux
    (res (copy ""))
    (re-html-ec (regcomp "^([^%]*)%([0-9a-fA-F][0-9a-fA-F])"))
    (offset 0)
  )
  (while (regexec re-html-ec string offset)
    (nconc res (regsub re-html-ec 1))
    (put res -1 (xtoi (+ "0x" (regsub re-html-ec 2))))
    (setq offset (1 (get re-html-ec 2)))
  )
  (nconc res (subseq string offset))
  res
)

;; (html:quote-values string)
;; returns a new string quoting non-alphas in the form %xx

(defun html:quote-values (string &aux
    (res (copy ""))
    (re-html-tq (regcomp "^([0-9a-zA-Z_-]*)([^0-9a-zA-Z_-])"))
    (offset 0)
  )
  (while (regexec re-html-tq string offset)
    (nconc res (regsub re-html-tq 1))
    (with (cval (get (regsub re-html-tq 2) 0))
      (put res -1 #\%)
      (put res -1 (get (itox (/ cval 16)) 2))
      (put res -1 (get (itox (mod cval 16)) 2))
    )
    (setq offset (1 (get re-html-tq 2)))
  )
  (nconc res (subseq string offset))
  res
)

;; (html:decode_plus string)
;; decodes in place into the string (and returns it) '+' into spaces, and
;; sequences CR LF quoted into a single unix linefeed

(defun html:decode_plus (string)
  (if (not string) (setq string ""))
  (replace-string string  "[+]" " " :all t :quote t)
  (replace-string string  "%0[dD]%0[aA]" "\n" :all t :quote t)
  string
)

(defun html:quote-pre (string)
  (replace-string string "<" "&lt;" :all t :quote t)
)
