#!/home/htdocs/cgi-bin/newlisp

# Written by Eddie Rucker -- updated 10-22-2004
# updated to 1.13 - November 14th
# updated to 1.14 - November 16th - changed all deprecated integer to int
# version 1.15  fix for new context behaviour in (save-file-lock ...) L.M. March 2, 2006
# versiob 1.1.6 replaces deprecated 'symbol' with 'sym'

# On install
#  1. change the shbang above to your newlisp install location
#  2. change the constant exit-URL below to a URL to exit to
#  3. change the cookie-domain to your server (for alert events)

(constant 'exit-URL "http://newlisp.org/index.cgi?page=Code_Contributions")
(constant 'cookie-domain "newlisp.org")

# version 0.1 added bubbles to some of the buttons
# version 0.2 bug fixes
# version 0.3 bug fixes
# version 0.4 bug fixes
# version 0.5 del button clears panel
# version 0.6 bug fix and added exit link -- see the exit-URL below
# version 0.7 bug fix in edit with no end time
# version 0.8 added reminder function warns about 5 minutes before event
# version 0.9 bug fix
# version 0.91 a function clean up
# version 1.0 cookie expiration for 5 minutes past current time and conditional disabling of input fields
# version 1.1 javascript fixes and change in font size for events
# version 1.2 function cleanup, 
#             font changes -- large type for main, small-type for week and month (printer friendly), 
#             added time-zone function
# version 1.3 bad bubble name next month and next year were called previous month
#             changed the "#" for reminder to registered mark (is this legal?)
# version 1.4 added img bell.png for Reminders
# version 1.5 bugfix in timezone
# version 1.6 bugfix -- clear event list so that todays events don't carry over
# version 1.7 cleanup and bugfix set timezone as a constant
# version 1.8 fixed a bug in the previous or next month with the day value being wrong -- thanks Sam!
# version 1.81 function cleanup - rid extra setqs in next year and previous year
#             a few documentation and format changes
# version 1.82 changed new button to clear "its meaning is more clear" tables:collapsed
# version 1.9 previously overlooked the cookie's domain server
# version 1.10  changed all 'collect' to 'select', which since 8.2.0 accepts both syntax's
# version 1.11  changed all 'getenv' to 'env'
# version 1.12  catch for load for version 8.7.0
# version 1.13  took away quite from inc argument L.M

(context 'CGI)

# get cgi request and convert hex values to characters
(setq req (replace {%([0-9A-F]{2})} 
		   (or (env "QUERY_STRING") "")
		   (char (int (append "0x" $1))) 
		   0))

# parse out value pairs
(map (fn (x) 
	 (let (L (parse x "=")) 
	   (set (sym (first L)) (last L))))
     (parse (replace "+" req " ") "[&;]" 0))

# get time cookies
(setq alert-cookies 
      (map (fn (x)
	       (last (parse x "=")))
	   (parse (or (env "HTTP_COOKIE") "") "[&;]" 0)))


(context 'EDB)

# initalize event list
(define (clear-events)
  (setq elist '()))

# write event list with a file lock
(define (save-file-lock fname)
  (while (file? "lock") 
    (sleep 100))
  (write-file "lock" "semaphore")
  (context 'MAIN) ; fix for 8.8.0
  (save fname 'elist)
  (context 'EDB) ; fix for 8.8.0
  (delete-file "lock"))

# get event from file
(define (get y m d)
  (if (catch (load (format "%d/%d/%d.lsp" y m d)) 'error)  elist '()))

# put event into file
(define (put y m d start-time end-time event remind)
  (setq elist 
	(unique 
	 (sort 
	  (cons 
	   (list start-time 
		 (if (= end-time -1)  -1  (max start-time end-time)) 
		 event
		 remind)
	   elist))))
  (make-dir (format "%d/" y))
  (make-dir (format "%d/%d/" y m))
  (save-file-lock (format "%d/%d/%d.lsp" y m d) elist)
  elist)

# delete nth event from file
(define (del y m d item)
  (pop elist item)
  (let (fname (format "%d/%d/%d.lsp" y m d))
    (if elist
	(save-file-lock fname elist)
	(delete-file fname))))

(define (event? y m d)
  (file? (format "%d/%d/%d.lsp" y m d)))


(context 'TIME)

(constant 'mdays '(0 31 28 31 30 31 30 31 31 30 31 30 31))
(constant 'timezone (nth 9 (now)))

(define (month-name m)
  (nth m '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))

(define (leap? y)
  (and (= 0 (% y 4)) 
       (or (!= 0 (% y 100))  (= 0 (% y 400)))))

(define (days-in-month y m)
  (+ (nth m mdays) 
     (if (and (leap? y) (= m 2))  1  0)))

(define (first-day-of-month y m)
  (% (+ (mul y 365.24258) 
	(apply + (slice mdays 0 m)) 
	(if (and (leap? y) (< m 3))  -1  0)) 
     7))

(define (days-until-end-of-month y m d)
  (- (days-in-month y m) d))

(define (days-until-end-of-year y m d)
  (- (apply + (map (fn (x) (days-in-month x)) (sequence m 12))) d))

(define (next-day y m d)
  (if (= (days-until-end-of-year y m d) 0)  (list (+ y 1) 1 1)
      (= (days-until-end-of-month y m d) 0) (list y (+ m 1) 1)
      (list y m (+ d 1))))

(define (next-month y m d , yy mm dd)
  (list
    (setq yy (if (= m 12) (+ y 1) y))
    (setq mm (if (= m 12) 1 (+ m 1)))
    (if (> d (setq dd (days-in-month yy mm))) dd d)))

(define (previous-month y m d , yy mm dd)
  (list
    (setq yy (if (= m 1) (- y 1) y))
    (setq mm (if (= m 1) 12 (- m 1)))
    (if (> d (setq dd (days-in-month yy mm))) dd d)))

(define (next-year y m d , yy dd)
  (list
    (setq yy (+ y 1))
    m
    (if (> d (setq dd (days-in-month yy m))) dd d)))

(define (previous-year y m d , yy dd)
  (list
    (setq yy (- y 1))
    m
    (if (> d (setq dd (days-in-month yy m))) dd d)))

(define (mil->string t)
  (if (<= 0 t 2359)
      (let (p (/ t 100))
	(let (h (% p 12))
	  (format "%d:%02d %sM" 
		  (if (= 0 h)  12  h) 
		  (% t 100)
		  (if (< p 12)  "A"  "P"))))
      ""))

(define (time->mil h m ap)
  (+ (* 100 (% h 12))  m  (if (= "AM" ap)  0  1200)))

(define (time->parts t)
  (if (= t -1)
      (list "1" "00" "AM")
      (let (p (/ t 100))
	(let (h (% p 12))
	  (list (string (if (= 0 h)  12  h))
		(format "%02d" (% t 100))
		(if (< p 12)  "AM"  "PM"))))))

;(define (dup s n)
;  (if (= n 0)  '()  (map (fn (x) s) (sequence 1 n))))

(define (->weeks L)
  (if (<= (length L) 7)
      (list (append L 
		    (dup 0 (- 7 (length L)))))
      (cons (slice L 0 7) 
	    (->weeks (slice L 7)))))

(define (month y m)
  (->weeks (append (dup 0 (first-day-of-month y m)) 
                   (sequence 1 (days-in-month y m)))))

(context 'MAIN)

(define (events->html L interactive)
  (if (empty? L)
      (format "<dt>%s</dt>\n" 
	      (if interactive  "<p class=\"big\" style=\"text-align:center\">No Events</p>\n"  ""))
      (format "<dl %s>%s</dl>\n"
	      (if interactive  "class=\"big\""  "")
	      (let (st 0 et 0 i -1)
		(join
		 (map (fn (x)
			  (let (start-time (first x)
			        end-time (nth 1 x)
				event (append 
				       (if interactive
					   (append 
					    (format "<input type=\"radio\" name=\"item\" value=\"%d\" %s onfocus=\"refresh_flag=false;\" />\n" 
						    (inc i)
						    (if (= i item) "checked=\"checked\"" ""))
					    (if (= (last x) 1) "<img src=\"bell.png\" />&nbsp;" ""))
					   "")
				       (nth 2 x)))
			    (if (or (and (= st start-time)  (= et end-time))  (= start-time -1))
				(format "<dd>%s</dd>" event)
				(format "<dt>%s - %s</dt>\n<dd>%s</dd>"
					(TIME:mil->string (setq st start-time))
					(if (= end-time -1)  ""  (TIME:mil->string (setq et end-time)))
					event))))
		      L)
		 "\n")))))

(define (get-week_ L d)
  (if (empty? L)         '() 
      (find d (first L)) (first L)
      (get-week_ (rest L) d)))
   
(define (get-week y m d)
  (get-week_ (TIME:month y m) d))
  
(define (week->html y m d)
  (append
   "<table width=\"100%\" cellspacing=\"0\">\n<tr>\n"
   (join
    (map (fn (x) 
	     (format "<th>%s</th>\n" x))
	 '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")))
   "</tr>\n<tr>\n"
   (join
    (map 
     (fn (x) 
	 (format {<td style="width:14.2%%; height:80px">%s</td>}
		 (if (= x 0)
		     "&nbsp;"
		     (append (format "<p style=\"text-align:right\">%d</p>" x)
			     (if (EDB:event? y m x)  (events->html (EDB:get y m x))  "")))))
     (get-week y m d)))
   "</tr>\n</table>\n"))

(define (month->html y m interactive)
  (append 
   "<table width=\"100%\" cellspacing=\"0\" align=\"center\">\n<tr>\n"
   (join
    (map 
     (fn (x)
	 (format "<th width=\"14.28%%\">%s</th>\n" x))
     (if interactive
	 '("S" "M" "T" "W" "T" "F" "S")
       '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))))
   "</tr>\n"
   (join
    (map 
     (fn (a)
	 (format "<tr>%s</tr>\n"
		 (join
		  (map 
		   (fn (b)
		       (format "<td %s>%s</td>\n"
			       (if interactive  ""  "style=\"height:80px\"")
			       (if (= b 0)
				   "&nbsp;" # 0 means blank day
				   (if interactive
				       (format "<input type=\"submit\" name=\"chday\" value=\"%d\" style=\"width:32px%s\" />"
					       b
					       (if (EDB:event? y m b)  ";color:red"  ""))
				     (append 
				      (format "<p style=\"text-align:right\">%d</p>" b)
				      (if (EDB:event? y m b)  (events->html (EDB:get y m b))  ""))))))
		   a))))
     (TIME:month y m)))
   "</tr>\n</table>\n"))


# --- main program starts here ---
# initialize variables
(map set 
     '(cy cm cd c-hr c-mn) 
     (select (now (- 0 TIME:timezone)) 0 1 2 3 4))

(setq CGI:y (if CGI:y  (int CGI:y)  cy)
      CGI:m (if CGI:m  (int CGI:m)  cm)
      CGI:d (if CGI:chday 
		(int CGI:chday) 
	      (if CGI:d  (int CGI:d)  cd)))

# see if there are any reminders
(setq c-time     (+ (* c-hr 100) c-mn)
      reminders  (filter (fn (x) 
                             (and (= (last x) 1)
				  (not (find (string (first x)) CGI:alert-cookies))
				  (<= (- (first x) 5) c-time (first x))))
			 (EDB:get cy cm cd))
      alert-time (if reminders  (first (first reminders))  nil))

# get events
(EDB:clear-events)
(setq event-list (EDB:get CGI:y CGI:m CGI:d))

# execute command
(case CGI:cmd
  ("Clear"
   (setq CGI:text nil 
	 CGI:allday nil 
	 CGI:remind nil
	 CGI:endtime "yes"
	 CGI:s_hr "1" 
	 CGI:s_mn "00" 
	 CGI:s_ap "AM"
	 CGI:e_hr "1" 
	 CGI:e_mn "00" 
	 CGI:e_ap "AM"))

  ("Add" 
   (EDB:put CGI:y CGI:m CGI:d 
	    (if CGI:allday 
		-1 # -1 is indicates all day event
		(TIME:time->mil (int CGI:s_hr) (int CGI:s_mn) CGI:s_ap))
	    (if (not CGI:endtime)
		-1 # -1 is indicates no end time
		(TIME:time->mil (int CGI:e_hr) (int CGI:e_mn) CGI:e_ap))
	    CGI:text
	    (if CGI:remind 1)))

  ("Del" 
   (if CGI:item 
       (begin
	 (EDB:del CGI:y CGI:m CGI:d (int CGI:item))
	 (setq CGI:text nil 
	       CGI:allday nil 
	       CGI:remind nil
	       CGI:endtime "yes"
	       CGI:s_hr "1" 
	       CGI:s_mn "00" 
	       CGI:s_ap "AM"
	       CGI:e_hr "1" 
	       CGI:e_mn "00" 
	       CGI:e_ap "AM"))))

  ("Edit" 
   (if (and CGI:item event-list)
       (begin
	 (map set 
	      '(start-time end-time CGI:text) 
	      (nth (int CGI:item) event-list))
	 (if (= start-time -1)
	     (setq CGI:allday "on")
	     (map set 
		  '(CGI:s_hr CGI:s_mn CGI:s_ap) 
		  (TIME:time->parts start-time)))
	 (if (= end-time -1)
	     (setq CGI:endtime nil)
	     (map set 
		  '(CGI:e_hr CGI:e_mn CGI:e_ap) 
		  (TIME:time->parts end-time)))
	 (EDB:del CGI:y CGI:m CGI:d (int CGI:item)))))

  ("<<" 
   (map set '(CGI:y CGI:m CGI:d) (TIME:previous-year CGI:y CGI:m CGI:d)))

  (">>" 
   (map set '(CGI:y CGI:m CGI:d) (TIME:next-year CGI:y CGI:m CGI:d)))

  ("<" 
   (map set '(CGI:y CGI:m CGI:d) (TIME:previous-month CGI:y CGI:m CGI:d)))

  (">" 
   (map set '(CGI:y CGI:m CGI:d) (TIME:next-month CGI:y CGI:m CGI:d)))

  ("Week" 
   (setq html-body 
	 (append 
	  (format "<h1>%s %d</h1>\n" 
		  (TIME:month-name (int CGI:m)) 
		  (int CGI:y))
	  (week->html (int CGI:y) (int CGI:m) (int CGI:d)))))

  ("Month" 
   (setq html-body 
	 (append
	  (format "<h1>%s %d</h1>\n" 
		  (TIME:month-name (int CGI:m)) 
		  (int CGI:y))
	  (month->html (int CGI:y) (int CGI:m))))))

# print header
(if alert-time
    (print  
     (setq expires 
	   (format "Set-cookie: alert%d=%d; expires=%s; path=/; domain=%s\n" 
		   alert-time 
		   alert-time
		   (apply (fn (d0 d1 d2 d3 d4) 
			      (format "%s, %s-%s-%s %s GMT" d0 d1 d2 d3 d4))
			  (select 
			   (parse (date (apply date-value (now (+ 5 TIME:timezone)))) " ")
			   0 2 1 5 3))
		   cookie-domain))))

(print
[text]Content-type: text/html

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>Calendar</title>
<style>
@page {size:8.5in 11in landscape; margin:0.25in}
body {font-family:sans-serif; font-size:12pt;}
h1 {text-align:center; font-size:18pt; margin:9px}
table {font-family:sans-serif; border-collapse:collapse}
th {background-color:black; color:white; border:1px solid black; margin-bottom:4px}
td {border:1px solid black; vertical-align:top}
dl {font-size:8pt; margin:0px}
dt {font-weight:bold; margin-top:6px}
dd {margin-left:0.125in}
p {text-align:right; font-size:7pt; font-weight:bold; margin:0px}
.big { font-size: 12pt }
</style>
<script language="JavaScript1.2">
var surl = unescape(document.location);
var refresh_flag = true;
function doLoad() { 
  disable();
  setTimeout("refresh()", 10000); 
}
function refresh() {
  if (refresh_flag) {
    if (surl.match(/&cmd=(Clear|Del)/)) {
      document.location = surl.replace(/y=(\d+)&m=(\d+)&d=(\d+).*/, "y=$1&m=$2&d=$3");
    } else if (surl.match(/&cmd=(Add|Edit)/)) {
      document.location = surl.replace(/&cmd=.*/, "");
    } else {
      window.location.reload(false);
    }
  }
}
function disable() {
  if (document.formid.allday == null) {
		return;
	}
  if (document.formid.allday.checked) {
    document.formid.remind.disabled = 
    document.formid.s_hr.disabled = 
    document.formid.s_mn.disabled = 
    document.formid.s_ap.disabled = 
    document.formid.e_hr.disabled = 
    document.formid.e_mn.disabled = 
    document.formid.e_ap.disabled = 
    document.formid.endtime.disabled = true;
  } else { 
    document.formid.remind.disabled = 
    document.formid.s_hr.disabled = 
    document.formid.s_mn.disabled = 
    document.formid.s_ap.disabled =
    document.formid.endtime.disabled = false;
    if (document.formid.endtime.checked) {
      document.formid.e_hr.disabled =
      document.formid.e_mn.disabled =
      document.formid.e_ap.disabled = false;
    } else {
      document.formid.e_hr.disabled = 
      document.formid.e_mn.disabled = 
      document.formid.e_ap.disabled = true;
    }
  }
}
</script>
</head>
<body onload="doLoad()">
<form id="formid" name="formid" action="ecal.cgi" method="get">
[/text]

(format "<input type=\"hidden\" name=\"y\" value=\"%d\">\n" CGI:y)
(format "<input type=\"hidden\" name=\"m\" value=\"%d\">\n" CGI:m)
(format "<input type=\"hidden\" name=\"d\" value=\"%d\">\n" CGI:d)

(or html-body
    (append
     [text]
     <table width="100%">
     <tr>
     <th>Today is
     [/text]
     
     (format "%s %d, %d &nbsp; %s" 
	     (TIME:month-name cm) 
	     cd 
	     cy 
	     (TIME:mil->string (+ (* c-hr 100) c-mn)))
     
     [text]
     </th>
     <th>Events for
     [/text]
     
     (format "%s %d, %d" (TIME:month-name CGI:m) CGI:d CGI:y)
     
     [text]
     </th>
     </tr>
     <tr>
     <td style="width:35%; text-align:center; border:1px solid black; vertical-align:top">
     <table align="center">
     <tr>
     <td>
     <input type="submit" name="cmd" value="&lt&lt" style="width:32px" title="Previous year"><input type="submit" name="cmd" value="&lt" style="width:32px" title="Previous month">
     </td>
     <td style="width:120px; text-align:center; font-size:10pt">
     [/text]
     
     (format "%s &nbsp; %d, %d" (TIME:month-name CGI:m) CGI:d  CGI:y)
     
     [text] 
     </td>
     <td>
     <input type="submit" name="cmd" value="&gt" style="width:32px" title="Next month"><input type="submit" name="cmd" value="&gt&gt" style="width:32px" title="Next year">
     </td>
     </tr>
     </table>
     [/text]
     
     (month->html CGI:y CGI:m "interactive")
     
     [text]
     </td>
     <td style="border:1px solid black">
     <div style="overflow:auto; width:auto; height:230px">
     [/text]
     
     (events->html (EDB:get CGI:y CGI:m CGI:d) "interactive")
     
     [text]
     </div>
     </td>
     </tr>
     <tr>
     <td colspan="2" style="text-align:center; border:1px solid black">
     All day event:
     [/text]
     
     (format "<input type=\"checkbox\" name=\"allday\" value=\"no\" %s onfocus=\"refresh_flag=false;\" onclick=\"disable();\" id=\"allday\" />\n"
	     (if CGI:allday "checked=checked" ""))

     " &nbsp; Reminder <img src=\"bell.png\" />:"

     (format "<input type=\"checkbox\" name=\"remind\" value=\"no\" %s onfocus=\"refresh_flag=false;\" id=\"remind\" />\n"
	     (if CGI:remind "checked=checked" ""))

     
     [text]
     <br />
     Start time:
     <select name="s_hr" id="s_hr" onfocus="refresh_flag=false;">
     [/text]

     (join 
      (map (fn (x) 
	       (format "<option value=\"%s\">%s</option>\n" x x))
	   (unique (cons (or CGI:s_hr "1") 
			 (map string 
			      (sequence 1 12))))))
     
     [text]
     </select>
     <select name="s_mn" onfocus="refresh_flag=false;">
     [/text]
     
     (join 
      (map (fn (x) (format "<option value=\"%s\">%s</option>\n" x x))
	   (unique (cons (or CGI:s_mn "00") 
			 (map (fn (x) 
				  (format "%02d" x)) 
			      (sequence 0 55 5))))))
     
     [text]
     </select>
     <select name="s_ap" id="s_ap" onfocus="refresh_flag=false;">
     [/text]
     
     (join 
      (map (fn (x) (format "<option value=\"%s\">%s</option>\n" x x))
	   (unique (cons (or CGI:s_ap "AM") '("AM" "PM")))))
     
     [text]
     </select> 
     End time:
     [/text]
     
     (format "<input type=\"checkbox\" name=\"endtime\" value=\"yes\" %s onfocus=\"refresh_flag=false;\" onclick=\"disable();\" id=\"endtime\" />\n"
	     (if CGI:endtime
		 "checked=\"checked\""
		 ""))
     
     "<select name=\"e_hr\" id=\"e_hr\" onfocus=\"refresh_flag=false;\">\n"
     
     (join 
      (map (fn (x) 
	       (format "<option value=\"%s\">%s</option>\n" x x))
	   (unique (cons (or CGI:e_hr "1") 
			 (map string 
			      (sequence 1 12))))))
     
     [text]
     </select>
     <select name="e_mn" id="e_mn" onfocus="refresh_flag=false;">
     [/text]
     
     (join 
      (map (fn (x) 
	       (format "<option value=\"%s\">%s</option>\n" x x))
	   (unique (cons (or CGI:e_mn "00") 
			 (map (fn (x) 
				  (format "%02d" x)) 
			      (sequence 0 55 5))))))
     
     [text]
     </select>
     <select name="e_ap" id="e_ap" onfocus="refresh_flag=false;">
     [/text]
     
     (join 
      (map (fn (x) (format "<option value=\"%s\">%s</option>\n" x x))
	   (unique (cons (or CGI:e_ap "AM") '("AM" "PM")))))

     [text]
     </select>
     &nbsp;
     <br />
     [/text]
     
     (format "<textarea name=\"text\" rows=\"3\" cols=\"62\" onfocus=\"refresh_flag=false;\">%s</textarea>\n"
	     (or CGI:text ""))
     
     [text]
     <br />
     <input type="submit" name="cmd" value="Clear" style="width:48px" title="Clear all fields"><input type="submit" name="cmd" value="Add" style="width:48px" title="Add an event"><input type="submit" name="cmd" value="Edit" style="width:48px" title="Edit an event"><input type="submit" name="cmd" value="Del" style="width:48px" title="Delete an event">
     &nbsp;
     <input type="submit" name="cmd" value="Week" title="View current week"><input type="submit" name="cmd" value="Month" title="View current month">
     &nbsp;
     [/text]

     (format "<a href=\"%s\">Exit</a>\n" exit-URL)

     [text]
     </td>
     </tr>
     </table>
     [/text]))

(if alert-time
    (format "<script>alert(\"You have an appointment at %s\");</script>\n" (TIME:mil->string (int alert-time)))
    "")

[text]
</form>
</body>
</html>
[/text])

(exit)