#!/usr/local/gauche/bin/gosh -I.

(use www.cgi)
(use srfi-27)
(use srfi-19)
(use text.html-lite)
(use text.tree)
(use srfi-1)
(use rfc.cookie)
(use file.util)
(use srfi-13)

(use session)

(define SESSIONDIR "/tmp/bb/session")
(define DATADIR "/tmp/bb/data")
(define USERPASS "/tmp/bb/users")
(define COOKIENAME "BBSESSID")
(define MAXAGE 600)    ; session lifetime in seconds

(define LOGIN-VALUE "Login")
(define NEWTOPIC-VALUE "New Topic")
(define SUBMITTOPIC-VALUE "Submit Topic")
(define LOGOUT-VALUE "Logout")
(define NEWMESSAGE-VALUE "New Message")
(define READTOPIC-VALUE "R")
(define MAINMENU-VALUE "Topic List")
(define SUBMITMESSAGE-VALUE "Submit Message")
(define NEWUSER-VALUE "New User")

;
; print-error
;
(define (pe . args)
  (for-each
   (lambda (thing) (display thing (current-error-port)))
   args)
  (newline (current-error-port))
  (flush (current-error-port)))

;
; print-flush
;
(define (pf . args)
  (for-each
   (lambda (thing) (display thing))
   args)
  (newline)
  (flush))

;
;
;
(define (user-is-guest)
  (string=? "guest" (session-get-var session "login")))

;
; generate-topic-id
;
(define (generate-msgid session)
  (format #f "~d-~a"
	  (time->seconds (current-time))
	  (session-get-var session "login")))

;
; header-wif-cookies
;
(define (header-wif-cookies session)
  (tree->string
   (cgi-header
    :cookies (construct-cookie-string
	      (list (list COOKIENAME (session-get-id session)))))))

;
; generate-topiclist
;
(define (make-dirlist session)
  (let ((dirlist (list)))
    (for-each
     (lambda (dir)
       (let ((inffile     (format #f "~a/~a/info" DATADIR dir))
	     (topic       #f)
	     (dlist       (string-split dir "-")))
	 (with-error-handler
	  (lambda (eo)  (set! topic "error-getting-topic"))
	  (lambda ()
	    (with-input-from-port (open-input-file inffile)
	      (lambda () (set! topic (read-line))))))
	 (push! dirlist (list dir topic (car dlist) (cadr dlist)))))
     (directory-list DATADIR :children? #t))
    (sort! dirlist (lambda (x y) (string<? (car x) (car y))))
    dirlist))

(define (generate-topiclist session)
  (html:table
   :width "100%"
   (html:tr
    :bgcolor "#8fff8f"
    (html:td "Read") (html:td "Topic") (html:td "Poster")
    (html:td "Date Posted"))
   (let ((flag 0)
	 (msgcolor #f))
     (map
      (lambda (dirinfo)
	(set! flag (- 1 flag))
	(set! msgcolor (if (= flag 0) "#cfcfff" "#cfcfcf"))
	(html:tr
	 :bgcolor msgcolor
	 (html:form
	  :method "POST" :action "/cgi-bin/bulletin.scm"
	  (html:input :name "topicid" :type "hidden" :value (car dirinfo))
	  (html:td (html:input :name "submit" :type "submit"
			       :value READTOPIC-VALUE))
	  (html:td (cadr dirinfo))
	  (html:td (cadddr dirinfo))
	  (html:td (date->string
		    (time-utc->date
		     (seconds->time
		      (string->number (caddr dirinfo)))))))))
      (make-dirlist session)))))

;
; generate-topic-html
;
(define (make-msglist session topicid)
  (let ((msglist (list)))
    (for-each
     (lambda (file)
       (if (not (string=? file "info"))
	   (let ((slist (string-split file "-")))
	     (push!
	      msglist
	      (list file (car slist) (cadr slist)
		    (port->string
		     (open-input-file
		      (format #f "~a/~a/~a" DATADIR topicid file))))))))
     (directory-list (format #f "~a/~a" DATADIR topicid) :children? #t))
    (sort! msglist (lambda (x y) (string<? (car x) (car y))))
    msglist))

(define (generate-topic-html session topicid)
  (html:table
   :width "100%"
   (html:tr
    :bgcolor "#8fff8f"
    (html:td "Poster") (html:td "Message"))
   (let ((flag 0)
	 (msgcolor #f))
     (map
      (lambda (thing)
	(set! flag (- 1 flag))
	(set! msgcolor (if (= flag 0) "#cfcfff" "#cfcfcf"))
	(html:tr
	 :bgcolor msgcolor
	 (html:td :valign "top" (caddr thing))
	 (html:td :width "90%"
		  (date->string
		   (time-utc->date
		    (seconds->time
		     (string->number (cadr thing)))))
		  (html:hr)
		  (cadddr thing))))
      (make-msglist session topicid)))))

;
; emit-newtopic
;
(define (emit-newtopic session)
  (display (header-wif-cookies session))
  (display
   (tree->string
    (html:html
     (html:head (html:title "Bulletin Board"))
     (html:body
      (html:h1 "Bulletin Board")
      (html:h2 "New Topic Smackdown")
      (html:form
       :method "POST" :action "/cgi-bin/bulletin.scm"
       (html:table
	(html:tr
	 (html:td :valign "top" "Subject :")
	 (html:td (html:input :name "topic" :type "input")))
	(html:tr
	 (html:td :valign "top" "Message :")
	 (html:td (html:textarea :name "blather" :cols 60 :rows 12))))
       (html:table
	(html:tr
	 (html:td (html:input :name "submit" :type "submit"
			      :value SUBMITTOPIC-VALUE))
	 (html:td (html:input :name "submit" :type "submit"
			      :value MAINMENU-VALUE))
	 (html:td (html:input :name "submit" :type "submit"
			      :value LOGOUT-VALUE)))))))))
  (newline))

;
; emit-newmessage
;
(define (emit-newmessage session topicid)
  (display (header-wif-cookies session))
  (display
   (tree->string
    (html:html
     (html:head (html:title "Bulletin Board"))
     (html:body
      (html:h1 "Bulletin Board")
      (html:h2 "Add Message to Current Topic")
      (html:form
       :method "POST" :action "/cgi-bin/bulletin.scm"
       (html:input :name "topicid" :type "hidden" :value topicid)
       (html:table
	(html:tr
	 (html:td :valign "top" "Message :")
	 (html:td (html:textarea :name "blather" :cols 60 :rows 12))))
       (html:table
	(html:tr
	 (html:td (html:input :name "submit" :type "submit"
			      :value SUBMITMESSAGE-VALUE))
	 (html:td (html:input :name "submit" :type "submit"
			      :value MAINMENU-VALUE))
	 (html:td (html:input :name "submit" :type "submit"
			      :value LOGOUT-VALUE)))))
       (generate-topic-html session topicid)))))
  (newline))

;
; emit-main
;
(define (emit-main session)
  (display (header-wif-cookies session))
  (display
   (tree->string
    (html:html
     (html:head (html:title "Bulletin Board"))
     (html:body
      (html:h1 "Bulletin Board")
      (html:form
       :method "POST" :action "/cgi-bin/bulletin.scm"
       (html:table
	(html:tr
	 (html:td (html:input :name "submit" :type "submit"
			      :value NEWTOPIC-VALUE))
	 (html:td (html:input :name "submit" :type "submit"
			      :value LOGOUT-VALUE)))))
      (generate-topiclist session)))))
  (newline))

;
; emit-login
;
; Emits an HTML login page.
;
(define (emit-login session message)
  (display (header-wif-cookies session))
  (display
   (tree->string
    (html:html
     (html:head (html:title "Bulletin Board"))
     (html:body
      (html:h1 "Bulletin Board Login")
      message
      (html:form
       :method "POST" :action "/cgi-bin/bulletin.scm"
       (html:table
	(html:tr (html:td "Username:")
		 (html:td (html:input :name "username" :type "text")))
	(html:tr (html:td "Password:")
		 (html:td (html:input :name "password" :type "password"))))
       (html:table
	(html:tr
	 (html:td (html:input :type "submit" :name "submit"
			      :value LOGIN-VALUE))
	 (html:td (html:input :type "submit" :name "submit"
			      :value NEWUSER-VALUE))))
     )))))
  (newline))

;
; emit-logout
;
(define (emit-logout)
  (display (tree->string (cgi-header)))
  (display
   (tree->string
    (html:html
     (html:head (html:title "Bulletin Board"))
     (html:body
      (html:h1 "Bulletin Board Logout")
      "You logged out, dawg.  Click "
      (html:a :href "/cgi-bin/bulletin.scm" "here") "to log back in."))))
  (newline))

;
; emit-topic
;
(define (emit-topic session topicid)
  (display (tree->string (cgi-header)))
  (let ((inffile     (format #f "~a/~a/info" DATADIR topicid))
	(topic       #f))
    (with-error-handler
     (lambda (eo) (set! topic "Error Reading Topic"))
     (lambda ()
       (with-input-from-port (open-input-file inffile)
	 (lambda () (set! topic (read-line))))))
    (display
     (tree->string
      (html:html
       (html:head (html:title "Bulletin Board"))
       (html:body
	(html:h1 "Bulletin Board Topic")
	(html:h2 topic)
	(html:form
	 :method "POST" :action "/cgi-bin/bulletin.scm"
	 (html:input :type "hidden" :name "topicid" :value topicid)
	 (html:table
	  (html:tr
	   (html:td (html:input :name "submit" :type "submit"
				:value MAINMENU-VALUE))
	   (html:td (html:input :name "submit" :type "submit"
				:value NEWMESSAGE-VALUE))
	   (html:td (html:input :name "submit" :type "submit"
				:value LOGOUT-VALUE)))))
	(generate-topic-html session topicid)))))))


;
; Handle page submissions
;
(define (handle-readtopic session params)
  (let ((topicid   (cgi-get-parameter "topicid" params)))
    (if (not topicid) (emit-main session) (emit-topic session topicid))))

(define (handle-logout session)
  (session-destroy session)
  (emit-logout))

(define (handle-topic session params)
  (letrec ((topicid (generate-msgid session))
	   (dir     (format #f "~a/~a" DATADIR topicid))
	   (msgpath (format #f "~a/~a" dir topicid))
	   (infpath (format #f "~a/info" dir))
	   (topic   (string-delete
		     (cgi-get-parameter "topic" params) #\newline)))
    (create-directory* dir)
    (with-output-to-port (open-output-file msgpath)
      (lambda ()
	(pf (cgi-get-parameter "blather" params))))
    (with-output-to-port (open-output-file infpath)
      (lambda ()
	(pf topic))))
  (emit-main session))

(define (handle-submitmessage session params)
  (let ((topicid (cgi-get-parameter "topicid" params)))
    (if (string? topicid)
	(begin
	  (with-output-to-port (open-output-file
				(format #f "~a/~a/~a" DATADIR topicid
					(generate-msgid session)))
	    (lambda ()
	      (pf (cgi-get-parameter "blather" params))))
	  (emit-topic session topicid))
	(emit-main session))))

(define (handle-newmessage session params)
  (let ((topicid (cgi-get-parameter "topicid" params)))
    (if (not topicid) (emit-main session) (emit-newmessage session topicid))))

;
; bulletin-board
;
; This is the ``main'' function for the bulletin board.  It dispatches
; submit button events that correspond to the various screens the user
; fiddles with.
;
(define (bulletin-board session params)
  (let ((submit (cgi-get-parameter "submit" params)))
    (if (not (string? submit)) (emit-main session)
	(cond
	 ((string=? submit MAINMENU-VALUE)    (emit-main session))
	 ((string=? submit NEWTOPIC-VALUE)    (emit-newtopic session))
	 ((string=? submit NEWMESSAGE-VALUE)  (handle-newmessage session
								 params))
	 ((string=? submit LOGOUT-VALUE)      (handle-logout session))
	 ((string=? submit SUBMITTOPIC-VALUE) (handle-topic session
							    params))
	 ((string=? submit SUBMITMESSAGE-VALUE) (handle-submitmessage session
								      params))
	 ((string=? submit READTOPIC-VALUE)   (handle-readtopic session
								params))
	 (else (emit-main session)))))
  (session-write session))

;
; username/password utilities
;

;
; read-password-file
;
; Reads a password file and returns a list of username/password lists.
;
(define (read-password-file filename)
  (let ((uplist   (list)))
    (with-error-handler
     (lambda (eo) (set! uplist (list)))
     (lambda ()
       (with-input-from-port (open-input-file USERPASS)
	 (lambda ()
	   (port-for-each
	    (lambda (line)
	      (push! uplist (string-split line #[\s])))
	    read-line)))))
    uplist))

;
; username-exists
;
; Returns true if a username exists.
;
(define (username-exists uplist username)
  (let ((pass   #f))
    (for-each
     (lambda (thing)
       (if (string=? username (car thing)) (set! pass (cadr thing))))
     uplist)
    pass))

;
; successful-login
;
; Returns true if a username/password is valid.  Returns false if not.
;
(define (successful-login username password)
  (let* ((uplist  (read-password-file USERPASS))
	 (pass    (username-exists uplist username)))
    (if (string? pass)
	(string=? password pass)
	#f)))

;
; new-login
;
; Creates a new user if the supplied username and password is not used
; and the username and password meet length and content requirements.
; Returns normally if successful.  Signals an error if failure.
;
(define (new-login username password)
  (let* ((uplist     (read-password-file USERPASS)))
    (cond
     ((string? (username-exists uplist username))
      (error "Username already exists."))
     ((> (string-length username) 24)
      (error "Username too long."))
     ((> (string-length password) 24)
      (error "Password too long."))
     ((number? (string-index username #[\s]))
      (error "Cannot have spaces in username."))
     ((number? (string-index password #[\s]))
      (error "Cannot have spaces in password."))
     ((> (length uplist) 24)
      (error "Too many usernames already."))
     (else
      (begin
	(push! uplist (list username password))
	(with-output-to-port (open-output-file USERPASS)
	  (lambda ()
	    (for-each
	     (lambda (thing)
	       (print (car thing) " " (cadr thing)))
	     uplist)))
	#t)))))

;
; main
;
; Starts the show.  Determine if there is an existing session with a
; valid login.  If there is then run the bulletin board otherwise
; give a login screen.
;
(define (main args)
  (let ((session (session-begin #f SESSIONDIR COOKIENAME))
	(params (cgi-parse-parameters)))
    (session-read session MAXAGE)
    (if (session-get-var session "login")
	(bulletin-board session params)
	(let ((username (cgi-get-parameter "username" params))
	      (password (cgi-get-parameter "password" params))
	      (submit   (cgi-get-parameter "submit"   params)))
	  (if (or (not username) (not password) (not submit))
	      (emit-login session "")
	      (cond
	       ((string=? LOGIN-VALUE submit)
		(if (successful-login username password)
		    ((lambda ()
		       (session-set-var session "login" username)
		       (bulletin-board session params)))
		    (emit-login session "Invalid username/password")))
	       ((string=? NEWUSER-VALUE submit)
		(with-error-handler
		 (lambda (eo)  (emit-login session (slot-ref eo 'message)))
		 (lambda ()
		   (new-login username password)
		   (session-set-var session "login" username)
		   (bulletin-board session params))))
	       (else (emit-login session "Evilness"))))))))