#!/usr/local/bin/klone
(setq max-level *maxint*)
(setq *package* 'A)

;;=============================================================================
;;                    Global vars
;;=============================================================================

;; %url and %dir are the base of sub-bases named by the sub-dirs present there
;; things you must change---------------------------------------------------
URL = "http://www.inria.fr/cgi-bin/nph-colas-aucland"
;; URL = "http://localhost/cgi-bin/nph-colas-aucland"
DIR = "/htdocs/files/koala/aucland"
;;DIR = "/var/www/webspace/pages/aucland"

MAINTAINER = "Colas.Nahaboo@sophia.inria.fr"
PAGE-COLOR = "#FFDDBB"
TITLE = "Aucland concours Einstein"
BASEFILE = "einstein.kdb"

PRE-TEXT = "Ont dja rpondu au concours aucland ( faire avant le 
12 Novembre),  l'URL <a href='http://www.aucland.fr/accdb/viewItem.asp?IDI=118544'>http://www.aucland.fr/accdb/viewItem.asp?IDI=118544</a> (attention: il faut d'abord s'identifier sur aucland, puis suivre le lien, et remplir le formulaire en bas de page), avec le nombre de bonnes rponses 
anticipes:\n
<p>La bonne rponse est:
<br><b>Nom de l'objet:</b> Le livre L'EVOLUTION DES IDEES EN PHYSIQUE  exposant La Theorie de la Relativit
<br><b>Inventeur:</b> Albert Einstein
<p>"
POST-TEXT = "<p><hr>Ajoutez votre rponse  la base:"

;; To administrate the base, use %url/name/admin

;;; things you dont need to change--------------------------------------------
(fdb:defstruct User
  :name					; the name of the User
  :number				; his proposed number
)

;; add here the path of the klone library accesible for cgi scripts:
;;(insert *load-pathname* 0 "/users/colas/Klone/src/kl")

;; some preloads for efficiency
(dolist (filename '("setqn.kl" "require.kl" "defstruct.kl" "numeric.kl" 
      "basename.kl" "cgi.kl" "filedatabase.kl" "++.kl" "+=.kl" "stack-dump.kl"
      "sh.kl" "statparams.kl" "octal.kl" "date.kl" "cur-date.kl" 
      "file-type.kl" "trap-error.kl" "replace-string.kl" "file-lock.kl" 
      "print-stack.kl"
  ))
  (load filename)
)

;; misc defs, internal use
(if (/= #\/ (get DIR -1)) (nconc DIR "/")) ;dir must be /-terminated
(setq PF print-format)
(setq Q html:quote-pre)

;;=============================================================================
;;                    main dispatch
;;=============================================================================

(defun main (&aux
    (re (regcomp "^[/]delete[/](.+)$"))
  )
  (stack-dump-on-error t *maxint* () print-stack-dump:pre-handler
    print-stack-dump:post-handler)	;full stack dump on errors
  (goto-dir DIR)
  (cgi:init :error (+ DIR "ERRORS"))
  ;; first, decide what want the user?
  (if
    (= cgi:path-info "")		;no subpart? mainpage
    (show-main-page)

    (= cgi:path-info "/admin")		;admin functions
    (admin-page)

    (= cgi:path-info "/add")
    (add-entry 
      (trim-whitespace (get cgi:arguments "name"))
      (trim-whitespace (get cgi:arguments "number"))
    )

    (re cgi:path-info)	;delete user
    (delete-user (html:unquote-values (re 1)))
    
    (PF "Unknown command!\n")		;there is a ball in the soup
  )
  (cgi:end)
)
;;=============================================================================
;;                    Main page: List database
;;=============================================================================
(defun show-main-page ()
  (PF "<HEAD><TITLE>%0</TITLE></HEAD><BODY BGCOLOR='%1'><H1>%0</H1>\n%2\n"
    TITLE PAGE-COLOR PRE-TEXT
  )
  (open-base)
  (sort BASE.records compare-records)	;sort per number
  (fdb:dolist (record BASE)
    (PF "<br><b>%0</b> %1\n" record.number record.name)
  )    
  (PF "\n%0\n<form method='post' action='%1/add'>
Nombre: <input name=number size=5 type=text>,
Nom: <input name=name size=50 type=text>
<input type=submit value='Enter'></form><hr>
</BODY></HEAD>\n" POST-TEXT URL)
)

(defun  compare-records (r1 r2)
  (compare r1.number r2.number)
)

(defun add-entry (name number &aux)
  (catch 'Return
    (if (= "" name) (throw 'Return
	(PAGE "ERROR! le champ Nom: doit tre rempli!"
	  :title "Formulaire incomplet"
      ))
      (not (match "^[0-9]+$" number))  (throw 'Return
	(PAGE "ERROR! le champ Nombre: doit tre un nombre positif!"
	  :title "Formulaire incomplet"
      ))
    )
    (open-base)
    (fdb:dolist (record BASE)
      (when (= record.name name)
	(setq record (fdb:edit-record BASE record))
	record.number = number
	(throw 'Return (PAGE (if (fdb:save-record BASE record)
	      (PF String "Une erreur a eu lieu, je n'ai pas pu enregistrer
                        le nom <b>%0</b>\n" name)
	      (PF String "Ok, done. <a href='%0'>Retour</a>.\n" URL)
	    )
	    :title "Ajout" 
    ))))
    ;; If we are here, we must add
    record = (fdb:add-record BASE)
    record.name = name
    record.number = number
    (PAGE (if (fdb:save-record BASE record)
	(PF String "Une erreur a eu lieu, je n'ai pas pu enregistrer
                        le nom <b>%0</b>\n" name)
	(PF String "Ok, done. <a href='%0'>Retour</a>.\n" URL)
      )
      :title "Ajout" 
    )
  )
)
;;=============================================================================
;;                    Admin
;;=============================================================================
(defun admin-page ()
  (PF "<HEAD><TITLE>%0</TITLE></HEAD><BODY BGCOLOR='%1'><H1>%0</H1>\n%2\n"
    TITLE PAGE-COLOR (+ PRE-TEXT "\n<p><b>Administration functions</b>")
  )
  (open-base)
  (sort BASE.records compare-records)	;sort per number
  (fdb:dolist (record BASE)
    (PF "<br><a href='%2/delete/%3'>DELETE</a> <b>%0</b> %1\n" 
      record.number record.name URL (html:quote-values record.name))
  ) 
  (PF "\n<hr></BODY></HEAD>\n")
)

(defun delete-user (name)
  (open-base)
  (setq record (find-record-of-name name))
  (PAGE 
    (if (and record (fdb:delete-record BASE record))
      (PF String "Une erreur a eu lieu, je n'ai pas pu supprimer <b>%0</b>\n"
	(Q name))
      (PF String "Ok, <b>%0</b> supprim. <a href='%1'>Retour</a>.\n"
	(Q name) URL)
    )
    :title "Supression"
  )
)

;;=============================================================================
;;                    misc utils
;;=============================================================================
;; read base, locks it. Creates it if it does not exist
(defun open-base ()
  (setq BASE (fdb:open BASEFILE))
  (if (/= BASEFILE (fdb:Base-filename BASE)) (progn
      (fdb:update-filename BASEFILE)
      (setq BASE (fdb:open BASEFILE))
  ))
  (if (not BASE) (progn
      (fdb:create BASEFILE User)
      (sh chmod a+rw ,BASEFILE)
      (setq BASE (fdb:open BASEFILE))
  ))
)

(defun find-record-of-name (name)
  (catch 'Found
    (fdb:dolist (record BASE)
      (if (= record.name name) (throw 'Found record))
    )
    ()
  )
)

(defun trim-whitespace (string &aux
    (res (copy ""))
    (re (regcomp "^([ \t\n]*)([^ \t\n]+)"))
    (offset 0)
  )
  (while (regexec re string offset)
    (if (and (/= 0 (length res)) 
	(/= 0 (length (regsub re 1)))) (nconc res " "))
    (nconc res (regsub re 2))
    (setq offset #[re 2 1])
  )
  res
)

;; trace

(defunq T (&rest args &aux 
    (T::fd (open (copy "") :type :string :direction :io)))
  (with (*standard-output* T::fd *standard-error* *standard-output*)
    (apply PV args)
  )
  (PF "<pre>\n%0\n</pre>\n" (Q (String T::fd)))
)

(defun goto-dir (dir &aux)
  (when (/= 'directory (file-type dir))
    (wait (system (list "rm" "-f" dir)))
    (wait (system (list "mkdir" "-p" dir)))
    (wait (system (list "chmod" "a+rwx" dir)))
  )
  *current-directory* = DIR
)

;;=============================================================================
;;                    error handler
;;=============================================================================

(defun PAGE (body &key
    (title "Error!")
    heading			;default same as title, "" to have nothing
    (color "#FFCCCC")
    (background ())
    (header "")
    (footer "")
  )
  (if (not heading) (setq heading title))
  (PF "<HEAD><TITLE>%0</TITLE></HEAD><BODY %2%3 %4%5>%7
    %1\n%6\n<hr>\n%8\n%9</BODY>\n"
    title				;0
    (if (= "" heading) "" (+ "<h1>" heading "</h1>")) ;1
    (if color "BGCOLOR=" "")		;2
    (if color (+ "\"" color "\"") "")	;3
    (if background "BACKGROUND=" "")	;4
    (if background (+ "\"" background "\"") "")	;5
    body				;6
    (if header header "")		;7
    ""					;8 links
    (if footer footer "")		;9
  )
)

(defun print-stack-dump:pre-handler (&rest args &aux 
    (date (html:date))
    s
    (dump (open (copy "") :type :string :direction :io))
  )
  (with (print-stack-dump:output dump
      print-stack-dump:exit-after ()
      print-stack-dump:print-local-vars t
      print-stack-dump:print-all-vars t
    ) 
    (apply print-stack-dump args)
  )
  (setq cgi:out-string
    (print-format String "<HTML><TITLE>Script Error!</TITLE>
<BODY BGCOLOR=\"#FFAAAA\">
Sorry, this cgi-script crashed in error. Please mail the maintainer:
<br><b>%2</b>
<br>that an error occured in
<br><b>%0</b>
<br>on
<br><b>%1</b><hr><pre>
%3
</pre>
</BODY></HTML>\n" URL date MAINTAINER (Q (String dump))))

  (cgi:end)
      
  (print-format *standard-error* "\n%2\n### ERROR in %0\n### on %1\n"
    URL date
    "========================================================================="
  )
)

(defun print-stack-dump:post-handler () (flush ())(sh sleep 2) (exit 0) )

(main)

;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***

