#!/usr/local/bin/siod -v0,-m3 -*-mode:lisp-*-

;; name: cookie.cgi
;; purpose: This demonstrates the use of set-cookies and is also
;;          a cookie diagnostic utility.
;; $Id: cookie.smd,v 1.1 1997/05/02 14:58:30 gjc Exp $

(define (main)
  (require "chtml.scm")
  (require "cgi.scm")
  (let ((table (cons-array 10))
	(template (load-chtml "cookie.html"))
	(data (mapcar (lambda (x)
			(list (substring x 0 (string-search "=" x))
			      (substring x (+ 1 (string-search "=" x)))))
		      *env*))
	(params nil))
    (hset table 'oflag 0)
    (hset table 'default-name "name")
    (hset table 'default-domain "")
    (hset table 'default-email-to "")
    (hset table 'default-smtp-via "")
    (hset table 'default-value (strftime "%T"))
    (hset table 'SCRIPT_NAME (getenv "SCRIPT_NAME"))
    (cond ((and (getenv "HTTP_COOKIE")
		(> (length (getenv "HTTP_COOKIE")) 0))
	   (hset table 'cflag 1)
	   (hset table 'cdata (html-encode (getenv "HTTP_COOKIE"))))
	  ('else
	   (hset table 'cflag 0)))
    (cond ((equal? "POST" (getenv "REQUEST_METHOD"))
	   (set! params (read-content-alist))
	   (hset table 'default-email-to
		 (or (cadr (assq 'TO params)) ""))
	   (hset table 'default-smtp-via
		 (or (cadr (assq 'SMTP params)) ""))
	   (cond ((assq 'refresh params))
		 ((assq 'email params)
		  (send-email-diag (or (cadr (assq 'SMTP params))
				       "")
				   (or (cadr (assq 'TO params))
				       "")))
		 ('else
		  (let ((name (or (cadr (assq 'NAME params)) ""))
			(value (or (cadr (assq 'VALUE params)) ""))
			(domain (or (cadr (assq 'DOMAIN params)) ""))
			(output nil))
		    (cond ((and (> (length name) 0) (> (length value) 0))
			   (set! output (string-append "Set-cookie: "
						       name "=" value "; "
						       "path=/"))
			   (if (> (length domain) 0)
			       (set! output (string-append
					     output
					     "; domain=" domain)))
			   (hset table 'oflag 1)
			   (hset table 'odata output))))))))
    (hset table 'nvars (length data))
    (hset table 'vars (mapcar html-encode (mapcar car data)))
    (hset table 'vals (mapcar html-encode (mapcar cadr data)))
    (if (href table 'odata)
	(writes nil (href table 'odata) "\n"))
    (if (equal? "save" (getenv "QUERY_STRING"))
	(let ((f (fopen "cookie.log" "a+")))
	  (print (cons (unix-ctime) *env*) f)
	  (fclose f)))
    (writes nil "Content-type: text/html\n\n")
    (write-chtml nil table template)))

(define (send-email-diag server to)
  (require 'smtp.scm)
  (or (gethostbyname server)
      (error "unknown server name" server))
  (set! to (string-trim to))
  (or (> (length to) 0) (error "no email address specified"))
  (send-data-via-smtp
   server
   (if (not (string-search "@" to))
       (string-append to "@" server))
   "cookie-diagnostic@nothing.nowhereXXXX.com"
   'generate
   *env*
   nil))