#| 
   Dictionary editing client implementation.

SHOULD BE REFACTORED.
   
   Author: Dmitri Hrapof <yavannadil@yahoo.com>
   Version: 0.4
   Copyright (C) 2004-2008 Dmitri Hrapof

This file is part of Geiriadur.

Geiriadur is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

Geiriadur is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Geiriadur; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  
|#

(in-package aranrod)

;(setf araneida::*log-stream* nil)

;  "Controls the disposition of errors signalled during handler methods.  If T, a backtrace will be printed to *TRACE-OUTPUT* and the ABORT-RESPONSE restart will be invoked to continue with the next request.  It may also be a designator for a function: if so it will be called with the consition signalled and should handle it, or return T or NIL which will be handled as above")
;(setf araneida::*restart-on-handler-errors* nil)

(defvar *wrl*
  (make-url :scheme "http" :host "localhost" :port 8000))

(defvar *listener*
  (make-instance 'serve-event-http-listener :port (url-port *wrl*)))

(defvar *edict* ())

(defstruct luser id pass salt)

(defvar *limit* 15)
(defvar *halen* (make-hash-table))
(defvar *users* (make-hash-table :test #'equal))
(defvar *cookies* (make-hash-table :test #'equal))
(defvar *continuations* (make-hash-table :test #'equal))
(defvar *attrs* (make-hash-table :test #'equal))
(defvar *parts* ())
(defvar *intl* 1)
(defvar *entl* 0)
(defvar =parts= ())
(defvar =langs= ())

(defparameter *orb* (CORBA:ORB_init))

(defun file-to-object (fn)
  (op:string_to_object 
   *orb* (with-open-file (rd fn :direction :input) (read-line rd))))

(defparameter *slovar* ())
(defparameter *dict* ())
(defparameter *master* ())

(defun connect-to-dictionary ()
  (setf *slovar* (file-to-object "geiriadur.ior")
	*master* (file-to-object "gweithdy.ior")
	*dict* (file-to-object "geiriadur1.ior")))

(defun corba-violation ()
  (dolist (d (clorb::io-descriptions-of clorb::*io-system*)) 
    (clorb::connection-close (clorb::io-descriptor-connection d))))

(defun corba-call (fn &rest args)
  (handler-case
      (apply fn args)
    #+clisp
    (system::simple-os-error ()
      (progn (corba-violation) (connect-to-dictionary) (apply fn args)))
    (omg.org/corba:object_not_exist () 
      (progn (corba-violation) (connect-to-dictionary) (apply fn args)))
    (omg.org/corba:comm_failure () 
      (progn (corba-violation) (connect-to-dictionary) (apply fn args)))
    (omg.org/corba:transient () 
      (progn (corba-violation) (connect-to-dictionary) (apply fn args)))))

(defun add-writers-digest (args user)
  (append
   args
   (list 
    (luser-id user) 
    (md5:md5sum-sequence 
     (format nil "~a~a~a" 
	     (luser-id user) (luser-salt user) (luser-pass user))))))

(defun secure-corba-call (req &rest fargus)
  (let ((user (request-user req)))
    (multiple-value-bind (ret once)
	(handler-case
	    (apply #'corba-call (add-writers-digest fargus user))
	  (dictionary:nopermission ()
	    (progn
	      (setf (luser-salt user) 
		    (corba-call #'op:once *master* (luser-id user)))
	      (apply #'corba-call (add-writers-digest fargus user)))))
      (setf (luser-salt user) once)
      ret)))						 

(defun choose-lang (&rest langs)
  (car (sort (set-difference (mapcar #'car =langs=) langs) #'<)))

(defun w>t (w)
  `(,(op:id w) 
    ,(op:lang w) 
    ,(op:prt w) 
    ,(op:value w) 
    ,(op:attr w)
    ,(op:pron w)))

(defun x>t (x)
  `(,(op:id x) ,(op:first x) ,(op:second x)))

(defun t>t (tr)
  `(,(op:id tr)
     ,@(w>t (op:first tr)) 
     ,@(w>t (op:second tr))
     ,(op:note tr)
     ,(op:usuality tr)
     ,(loop for x across (op:usage tr) collect (x>t x))))

(defun e>t (e)
  `(,(w>t (op:headword e))
    ,(loop for m across (op:meanings e) collect (t>t m))))

(defun e>>t (ee)
  (loop for e across ee collect (e>t e)))
  
(defgeneric obtain-translations (obj word from &optional to via))

(defmethod obtain-translations ((obj dictionary:lookup) 
				word from &optional to via)
  (if (not (stringp word))
      (values (e>>t (corba-call #'op:find obj word from)) 1)
      (if via 
	  (values (e>>t (corba-call #'op:interpret obj word from to via)) 3)
	(acond
	 ((e>>t (corba-call #'op:translate obj word from to)) (values it 1))
	 ((e>>t (corba-call #'op:etalsnart obj word from to)) (values it 2))
	 (t (declare (ignore it)) (values nil 3))))))

(defgeneric obtain-forms (obj word))

(defmethod obtain-forms ((obj dictionary:lookup) word)
  (loop for w across (corba-call #'op:paradigm obj word) collect (w>t w)))

(defun attrib (intl aaa)
  (format 
   nil "~{~a ~}"
   (mapcar
    #'(lambda (a)
	(if (char= #\( (schar a 0)) a
	    (let ((b (gethash a *attrs*))) (if b (svref b intl) a))))
    (split-sequence:split-sequence ; temporary hack
     (if (position #\| aaa) #\| #\Space) aaa :remove-empty-subseqs t))))


(defun word (intl c w)
  (let ((i (first w)))
    `(,@(if (= i (second w)) nil
	    `(,(clink (("paradigm" i) :class c) (fourth w))
	      ((span :class "t") " [" ,(sixth w) "] ") 
	      ,(aref *parts* (third w) intl) " - "))
	((span :class "a") ,(attrib intl (fifth w))))))

(defun ford (intl w)
  `(tr
    (td ,(fourth w) 
	((span :class "t" :style "color: red; font-size: 120%") 
	 ,(if (zerop (first w)) " ⚠" "")))
    (td ((span :class "t") "[" ,(sixth w) "]"))
    (td ,(attrib intl (fifth w)))))

(defun vord (intl w) 
  `(((span :class "y") ,(fourth w) " " ,(attrib intl (fifth w)))))

(defun trans-2 (intl p &optional (c "w") (no 0))
  `(((span :class ,(if (zerop (car p)) "v" c)) ,(format nil "~a. " no)) 
    ,@(if (zerop (car p)) 
	  (vord intl (nthcdr 7 p)) 
	  (word intl "m" (nthcdr 7 p))) " "
    ((span :class "c") ,(substitute #\Space #\| (nth 13 p))) 
    (br)
    ,@(apply 
       #'append 
       (mapcar
	#'(lambda (x)
	    `(((span :class "e") ,(second x) 
	       ,(if (char= #\► (schar (second x) 0)) " ≈ " " = ") 
	       ,(third x)) (br)))
	(nth 15 p)))))

(defun trans-1 (intl c no p) (trans-2 intl p c no))

(defun trans-3 (intl p)
  (append
   (if (not (zerop (car p)))
       `(((input :type "checkbox" 
		 :name ,(format nil "~a_~a" (second p) (eighth p)) 
		 :disabled))
	 ((input :type "checkbox" 
		 :name ,(format nil "~a_~a" (eighth p) (second p)) 
		 :disabled))))
   (trans-2 intl p)))

(defun trans-4 (intl p)
  (append 
   `(((input :type "checkbox" 
	    :name ,(format nil "~a_~a" (second p) (eighth p))))
     ((input :type "checkbox" 
	    :name ,(format nil "~a_~a" (eighth p) (second p)))))
   (trans-2 intl p)))

(defun show-results-1 (intl tuples)
  `((h3 "Прямой поиск")
    ,@(apply 
       #'append
       (mapcar
	#'(lambda (e)
	    `(,@(word intl "h" (car e)) (br)
		,@(if (find-if 
		       #'(lambda (p) (and (< 0 (car p)) 
					  (zerop (floor (nth 14 p) 10))))
		       (cadr e))
		      (apply 
		       #'append 
		       (mapcar 
			#'(lambda (p) (trans-2 intl p))
			(cadr e)))
		      (let (tt lliw (us 0) (no 0))
			(dolist (p (cadr e) (reverse tt))
			  (if (< 0 (car p))
			      (if (= us (floor (nth 14 p) 10))
				  (setf lliw "w")
				  (setf lliw "u" 
					us (floor (nth 14 p) 10) no (1+ no))))
			  (dolist (m (trans-1 intl lliw no p)) 
			    (push m tt)))))))
	tuples)) (hr)))

(defun show-results-1/2 (intl $w %f %t tuples)
  `((h3 "Прямой поиск")
    ,@(apply 
       #'append
       (mapcar
	#'(lambda (e)
	    `(,@(word intl "h" (car e)) (br)
		,@(if (find-if 
		       #'(lambda (p) (and (< 0 (car p)) 
					  (zerop (floor (nth 14 p) 10))))
		       (cadr e))
		      (apply 
		       #'append 
		       (mapcar 
			#'(lambda (p) (trans-2 intl p))
			(cadr e)))
		      (let (tt lliw (us 0) (no 0))
			(dolist (p (cadr e) (reverse tt))
			  (if (< 0 (car p))
			      (if (= us (floor (nth 14 p) 10))
				  (setf lliw "w")
				  (setf lliw "u" 
					us (floor (nth 14 p) 10) no (1+ no))))
			  (dolist (m (trans-1 intl lliw no p)) 
			    (push m tt)))))))
	tuples)) 
    (hr)
    (h3 "Перекрестный поиск")
    ((form :action "dict" :method "get") "через "
     ,(putin "hidden" %f) ,(putin "hidden" %t)
     ,(list-box =langs= (%v (choose-lang %f %t)))
     ,(putin "hidden" $w) (br)
     ((input :type "submit" :value "Искать")))))


(defun show-results-2 (intl tuples)
  `((h3 "Прямой поиск")
    (hr)
    (h3 "Обратный поиск")
    ,@(apply 
       #'append
       (mapcar
	#'(lambda (e)
	    `(,@(word intl "h" (car e)) (br)
		,@(apply 
		   #'append 
		   (mapcar #'(lambda (p) (trans-2 intl p)) (cadr e)))))
	tuples)) (hr)))

(defun show-results-3 (intl $w %f %t %v tuples)
  (let ((v (if %v %v (choose-lang %f %t))))
    `((h3 "Прямой поиск")
      (hr)
      (h3 "Обратный поиск")
      (hr)
      ,(if %v `(h3 "Перекрестный поиск") "Попробовать перекрестный поиск?")
      ((form :action "dict" :method "get") "через "
       ,(putin "hidden" %f) ,(putin "hidden" %t)
       ,(list-box =langs= v) ,(putin "hidden" $w) (br)
       ((input :type "submit" :value "Искать")))
      ,@(if tuples
	    `(,@(apply 
		#'append
		(mapcar
		 #'(lambda (e)
		     `(,@(word intl "h" (car e)) (br)
			 ,@(apply 
			    #'append 
			    (mapcar 
			     #'(lambda (p) (trans-3 intl p)) (cadr e)))))
		 tuples))
		(br)
		((input :type "submit" :value "Запомнить" :disabled))
		" "
		((a :href ,(format nil "swyddfa/dict?f=~a&t=~a&w=~a" %f %t $w))
		 "Редактирование словаря"))) (hr))))

(defun show-results-4 (intl $w %f %t %v tuples)
  (let ((v (if %v %v (choose-lang %f %t))))
    `((h3 "Прямой поиск")
      (hr)
      (h3 "Обратный поиск")
      (hr)
      ,(if %v `(h3 "Перекрестный поиск") "Попробовать перекрестный поиск?")
      ((form :action "dict" :method "get") "через "
       ,(putin "hidden" %f) ,(putin "hidden" %t)
       ,(list-box =langs= v) ,(putin "hidden" $w) (br)
       ((input :type "submit" :value "Искать")))
      ,@(if tuples
	    `(((form :method "post" :action "mpcreate")
	       ,@(apply 
		#'append
		(mapcar
		 #'(lambda (e)
		     `(,@(word intl "h" (car e)) (br)
			 ,@(apply 
			    #'append 
			    (mapcar 
			     #'(lambda (p) (trans-4 intl p)) (cadr e)))))
		 tuples))
	       (br)
	       ((input :type "submit" :value "Запомнить"))
	       " Чтобы создать и прямой, и обратный переводы, поставьте обе галочки"))) (hr))))

(defun lang-form (act $w &key %f %t %o (%l *limit*) (more t))
  `((form :name "f1" :method "get" :action ,act)
    (table
     ,(if %f `(tr (td "Исходный язык") (td ,(list-box =langs= %f))) '(tr))
     ,(if %t `(tr (td "Целевой язык") (td ,(list-box =langs= %t))) '(tr)))
    ,(putin "text" $w) (br)
    ,@(if %o
	  `(,(putin "hidden" %o) ,(putin "hidden" %l)
	     ((input 
	       :type "button" :value "&larr;"
	       :onclick "f1.o.value=parseInt(f1.o.value)-15; f1.submit();"
	       ,@(if (>= 0 %o) '(:disabled))))
	     ((input :type "submit" :value "Искать" :onclick "f1.o.value=0;"))
	     ((input 
	       :type "button" :value "&rarr;"
	       :onclick "f1.o.value=parseInt(f1.o.value)+15; f1.submit();"
	       ,@(if (not more) '(:disabled)))))
	  '(((input :type "submit" :value "Искать"))))))

(defparameter switch-script
  '(script "<!--
addEvent(window, \"load\", initSwitch);
function anotherOne (un, dau) {
  if (un == dau) {
    for (var i = 0; i < 5; i++) {
      if (i != un) return i; 
    }
  }
  return dau;
}
function addEvent(elm, evType, fn, useCapture)
// addEvent and removeEvent
// cross-browser event handling for IE5+,  NS6 and Mozilla
// By Scott Andrew
{
  if (elm.addEventListener){
    elm.addEventListener(evType, fn, useCapture);
    return true;
  } else if (elm.attachEvent){
    var r = elm.attachEvent(\"on\"+evType, fn);
    return r;
  }
}
function initSwitch()
{
  addEvent(f1.f, \"change\", function(){f1.t.selectedIndex = anotherOne(f1.f.selectedIndex,f1.t.selectedIndex);} );
  addEvent(f1.t, \"change\", function(){f1.f.selectedIndex = anotherOne(f1.t.selectedIndex,f1.f.selectedIndex);} );
}
-->"))

(defun choose-intl (req)
  (let ((intl (request-cookie req "intl")))
    (if intl (1+ (parse-integer intl)) *intl*)))

(defhandler dict-handler? ((%f 1) (%t 0) %v %i ($w ""))
  (write-html 
   req
   `(html
     (head 
      (title ,$w) 
      ((link :rel "stylesheet" :type "text/css" :href "/geiriadur.css")))
     ,switch-script
     (body
      (,@(lang-form "dict" $w :%f %f :%t %t))
      ,@(let ((secure (< 1 (length (request-handled-by req))))
	      (intl (choose-intl req)))
	     (multiple-value-bind
		   (tuples level)
		 (apply
		  #'obtain-translations 
		  (if secure *dict* *slovar*) 
		  (if %i (list %i %t) (list $w %f %t %v)))
	       (case level
		 (1 (if secure (show-results-1/2 intl $w %f %t tuples)
			(show-results-1 intl tuples)))
		 (2 (show-results-2 intl tuples))
		 (3 (if secure (show-results-4 intl $w %f %t %v tuples) 
			(show-results-3 intl $w %f %t %v tuples))))))
      ((a :href "./") "⌂")))))

(defun paradigm-proc (req intl %i forms)
  (write-html
   req
   `(html
     (head 
      (title ,(fourth (car forms)))
      ((link :rel "stylesheet" :type "text/css" :href "/geiriadur.css"))
      ((script :type "text/javascript" :src "/trefnutabl.js")))
     (body
      ((table :border "0" :style "width: 100%; text-align: left;"
	      :cellpadding "2" :cellspacing "2")
       (tr
	(td
	 "язык: " ,(cdr (assoc (second (car forms)) =langs=))
	 (br)
	 ,@(word intl "w" (car forms)))
	(td
	 "Перевести?"
	 ((form :action "dict" :method "get") "на "
	  ,(putin "hidden" %i) 
	  ,(putin "hidden" (%f (second (car forms)))) 
	  ,(putin "hidden" ($w (fourth (car forms)))) 
	  ,(list-box =langs= (%t (choose-lang (second (car forms)))))
	  (br)
	  ((input :type "submit" :value "Искать"))))))
      ((table :class "sortable" :id="ffurf" 
	      :border "1" :cellpadding "2" :cellspacing "2")
       (tr (td "Форма") (td "Транскрипция") (td "Атрибуты"))
       ,@(mapcar #'(lambda (p) (ford intl p)) (cdr forms)))))))
 
(defhandler paradigm-handler? ((%i 146089))
  (paradigm-proc 
   req (choose-intl req) %i 
   (obtain-forms 
    (if (< 1 (length (request-handled-by req))) *dict* *slovar*) %i)))

(defhandler mpcreate-handler ()
  (let ((count 0))
    (dolist (p (request-body req))
      (handler-case
       (progn
	 (apply 
	  #'secure-corba-call 
	  (append
	   (list req #'op:pcreate *master*)
	   (mapcar #'parse-integer (split-sequence:split-sequence #\_ (car p)))
	   (list "" 0)))
	 (incf count))
       (dictionary:oes () nil)))
    (write-html 
     req
     `(html
       (body "Создано переводов: " ,count)))))

; не переписать ли все это с помощью ContextL?

(let ((lliw '("gray" "green")) (ic 0) (ci 0))
  (defun display-trans ($c p)
    (let ((%tran (op:id p))
	  (%first (op:id (op:first p)))
	  (%second (op:id (op:second p)))
	  (%t (op:lang (op:second p)))
	  (%f (op:lang (op:first p)))
	  (%u (op:usuality p))
	  ($comment (html-escape (op:note p)))
	  (v1 (op:value (op:first p)))
	  (v2 (op:value (op:second p))))
      (if (/= ci %first) (setf ic (- 1 ic) ci %first))
      (if (zerop %tran)
	  `(p
	    ((font :color ,(nth ic lliw)) ,%tran)
	    ((a :href ,(format nil "dict?f=~a&t=~a&w=~a" %f %t v1) 
		:style "color: red")
	     ,v1) " "
	    ((a :href 
		,(format nil "zlist2?first=~a&t=~a&w=^$&c=~a" %first %t $c))
	     "♲"))
	  `((form :method "post" :action "pedit")
	    ,(putin "hidden" $c)
	    ,(putin "hidden" %tran)
	    ,(putin "hidden" %first)
	    ,(putin "hidden" %second)
	    ((font :color ,(nth ic lliw)) ,%tran)
	    ,v1 " = " ,(putin "text" %u :size "5") " "
	    ((a :href ,(format 
			nil 
			"zlist3?tran=~a&c=~a&t=~a&w=^~a$" %tran $c %t v2))
	     ,(if (> 10 %second) "." v2)) " "
	    ,(putin "text" $comment)	
	    ((input :type "submit" :value "✍")) " "
	    ((a :href ,(format nil "destroy?t=p&id=~a&c=~a" %tran $c)
		:onclick 
		,(format nil "return confirm('Удалить ~a=~a ~a?')" 
			 v1 v2 $comment)) 
	     "☠") " "
	    ((a :href ,(format nil "xlist?id=~a&c=~a" %tran $c))
	     ((font :color ,(if (zerop (op:id (svref (op:usage p) 0))) 
				"red" "blue")) "◊")) " "
	    ((a :href ,(format nil "zlist2?first=~a&t=~a&w=^$&c=~a" 
			       %first %t $c))
	     "♲") " "
	    ,@(if (> %second 10)
		  `(((a :href 
			,(if (zerop (op:id (svref (op:usage p) 1)))
			     (format nil "spcreate?first=~a&second=~a&c=~a"
				     %second %first $c)
			     (format nil "plist?f=~a&t=~a&w=%5E~a%24" 
				     %t %f v2)))
		     ((font :color 
			    ,(if (zerop (op:id (svref (op:usage p) 1))) 
				 "red" "blue")) "↔")))))))))

;все-таки, наверно, спрятать req в write-html
(defcontinuation plist-proc (%o %l %f %t $w)
  (let* ((1p (1+ %l))
	 (rez (corba-call #'op:plist *master* %f %t $w %o 1p))
	 (len (length rez))
	 (more (= 1p len))
	 (page (if more (subseq rez 0 %l) rez)))
    (write-html
     req
     `(html
       (head (title "Список переводов = Rhestr gyfieithiadau"))
       ,switch-script
       (body
	(h1 "Список переводов = Rhestr gyfieithiadau")
	(,@(lang-form "plist" $w :%f %f :%t %t :%o %o :more more))
	,@(map 'list #'(lambda (p) (display-trans c/c p)) page)
	((form :method "get" :action "zlist1")
	 (h2 "Новый перевод = Cyfieithiad newydd")
	 ,(list-box =langs= %f)
	 ,(let ((w "")) (putin "text" w))
	 ((input :type "submit"))))))))

(defhandler plist-handler? ((%o 0) (%l *limit*) (%f 0) (%t 1) ($w "^а"))
  (plist-proc req %o %l %f %t $w))

(defun display-example ($c tran x)
  (let ((id (op:id x)))
    `((form :method "post" :action "xedit")
      ,(putin "hidden" $c)
      ,(putin "hidden" id)
      ,(putin "text" (%first (html-escape (op:first x)))) " = "
      ,(putin "text" (%second (html-escape (op:second x))))
      ((input :type "submit")) " "
      ,(clink (("destroy" (t "x") id $c) :onclick "return confirm('Удалить?')") 
	     "☠")
      ,(clink (("shuffle" tran id (d 1) $c)) "&uarr;")
      ,(clink (("shuffle" tran id (d 0) $c)) "&darr;"))))
    
(defun new-example ($c %id &aux (op 0) (first "") (second ""))
  `((form :method "post" :action "xedit")
    ,(putin "hidden" op)
    ,(putin "hidden" $c)
    ,(putin "hidden" %id)
    ,(putin "text" first) " = "
    ,(putin "text" second)
    ((input :type "submit"))))

(defcontinuation xlist-proc (%id $c)
  (write-html
   req
   `(html
     (head (title "Примеры = Enghreifftiau"))
     (body
      (h1 "Примеры = Enghreifftiau")
      ,(clink (("cont" $c)) "&larr;")
      ,@(map 'list #'(lambda (x) (display-example c/c %id x))
	     (corba-call #'op:xlist *master* %id))
      ,(new-example c/c %id)))))

(defhandler xlist-handler? (%id $c) (xlist-proc req %id $c))

(defhandler xedit-handler ((%op 1) %id $first $second $c) 
  (if (and $first $second %id $c)
      (progn
	(secure-corba-call 
	 req
	 (if (zerop %op) #'op:xcreate #'op:xedit)
	 *master*
	 (dictionary:example 
	  :id %id :first $first :second $second))
	(funcall (gethash $c *continuations*) req))
      (request-redirect req "index")))

(defun dizplay-word-1 (w)
  `(,(putin "radio" (%first (op:id w))) ,@(word *entl* "w" (w>t w)) (br)))

(defun dizplay-word-2 (w ht)
  (if (= (op:id w) (op:lang w))
      `()
      (if ht
	  `(,(putin "radio" (%second (op:id w)) :disabled) 
	     ,@(word *entl* "w" (w>t w)) (br))
	  `(,(putin "radio" (%second (op:id w))) 
	     ,@(word *entl* "w" (w>t w)) (br)))))

(defun dizplay-word-3 (sec w ht)
  (if (= (op:id w) (op:lang w))
      `()
      (if ht
	  (if (= sec (op:id w))
	      `(,(putin "radio" (%second (op:id w)) :checked) 
		 ,@(word *entl* "w" (w>t w)) (br))
	      `(,(putin "radio" (%second (op:id w)) :disabled) 
		 ,@(word *entl* "w" (w>t w)) (br)))
	  `(,(putin "radio" (%second (op:id w))) 
	     ,@(word *entl* "w" (w>t w)) (br)))))

(defun display-word ($c w)
  `((form :method "post" :action "edit" :id ,(format nil "sf~a" (op:id w))
	  :onsubmit ,(format nil "if (sf~a.v.value=='~a') { return true; } else return confirm('Изменить ~a?');" (op:id w) (op:value w) (op:value w)))
    ((a :href ,(format nil "paradigm?i=~a" (op:id w))) ,(op:id w))
    ,(putin "hidden" $c)
    ,(putin "hidden" ($t "s"))
    ,(putin "hidden" (%word (op:id w)))
    ,(putin "hidden" (%lang (op:lang w)))
    ,(putin "text" ($val (op:value w)) :id "v")
    ,(list-box =parts= (%part (op:prt w)))
    ((span :class "t") "[" ,(putin "text" ($pron (op:pron w))) "]")
    ,(putin "text" ($attr (html-escape (op:attr w))))
    ((input :type "submit" :value "✍")) " "
    ((a :href ,(format nil "list?t=f&id=~a&c=~a" (op:id w) $c)) "☑")
    ((a :href ,(format nil "list?t=k&id=~a&c=~a" (op:id w) $c)) "√")))

(defun display-ending ($c w)
  `((form :method "post" :action "edit")
    ,(op:id w)
    ,(putin "hidden" $c)
    ,(putin "hidden" ($t "e"))
    ,(putin "hidden" (%word (op:id w)))
    ,(putin "hidden" (%lang (op:lang w)))
    ,(putin "text" ($val (op:value w)))
    ,(list-box =parts= (%part (op:prt w)))
    ((span :class "t") "[" ,(putin "text" ($pron (op:pron w))) "]")
    ,(putin "text" ($attr (html-escape (op:attr w))))
    ((input :type "submit"))))

(defun display-form ($t $c w)
  `((form :method "post" :action "edit")
    ,(putin "hidden" $c)
    ,(putin "hidden" $t)
    ,(putin "hidden" (%word (op:id w)))
    ,(putin "hidden" (%lang (op:lang w)))
    ,(putin "hidden" (%part (op:prt w)))
    ,(putin "text" ($val (op:value w)))
    ((span :class "t") "[" ,(putin "text" ($pron (op:pron w))) "]")
    ,(putin "text" ($attr (html-escape (op:attr w))))
    ((input :type "submit")) " "
    ((a :href ,(format nil "destroy?t=~a&id=~a&c=~a" $t (op:id w) $c)
	:onclick "return confirm('Удалить?')") "☠")))

(defcontinuation zlist1-proc (%o %l %f $w)
  (let* ((1p (1+ %l))
	 (rez (corba-call #'op:list *master* :S %f $w t 0 nil %o 1p))
	 (len (length rez))
	 (more (= 1p len))
	 (page (if more (subseq rez 0 %l) rez)))
  (write-html
   req
   `(html
     (head 
      (title "Создание перевода = Cread cyfieithiad")
      ((link :rel "stylesheet" :type "text/css" :href "/geiriadur.css")))
     (body
      (h1 "Создание перевода = Cread cyfieithiad")
      ((a :href "plist") "&larr;")
      (,@(lang-form "zlist1" $w :%f %f :%o %o :more more))
      ((form :method "get" :action "zlist2")
       ,@(apply #'append (map 'list #'dizplay-word-1 page))
       ,(putin "hidden" ($c c/c))
       ,(list-box =langs= (%t (choose-lang %f)))
       ,(putin "text" (w ""))
       ((input :type "submit"))))))))

(defhandler zlist1-handler? ((%o 0) (%l *limit*) (%f 0) ($w "^а"))
  (zlist1-proc req %o %l %f $w))

(defhandler zlist2-handler? ((%o 0) (%l *limit*) %first %t $w $c)
  (if (and %first %t $w $c)
      (multiple-value-bind 
	    (rez1 rez2) 
	  (corba-call #'op:zlist *master* %t $w %first %o (1+ %l))
	(let* ((1p (1+ %l))
	       (len (length rez1))
	       (more (= 1p len))
	       (ws (if more (subseq rez1 0 %l) rez1))
	       (hts (if more (subseq rez2 0 %l) rez2)))
	  (write-html
	   req
	   `(html
	     (head 
	      (title "Создание перевода = Cread cyfieithiad")
	      ((link :rel "stylesheet" :type "text/css" 
				       :href "/geiriadur.css")))
	     (body
	      (h1 "Создание перевода = Cread cyfieithiad")
	      "Исходный язык: " 
	      ,@(let ((wd (w>t (svref (corba-call #'op:paradigm *dict* %first) 
				      0))))
		     `(,(cdr (assoc (second wd) =langs=)) (br)
			,(first wd) " " ,@(word *entl* "w" wd)))
	      ((a :href ,(format nil "cont?c=~a" $c)) "&larr;") (hr)
	      (,@(lang-form "zlist2" $w :%t %t :%o %o :more more)
		 ,(putin "hidden" %first) ,(putin "hidden" $c))
	      ((form :method "post" :action "pedit")
	       ,(putin "hidden" (%op 0))
	       ,(putin "hidden" %first)
	       ,@(apply #'append (map 'list #'dizplay-word-2 ws hts))
	       ,(putin "radio" (%second %t))
	       ((font :color "green") "Толкование") (br)
	       ,(putin "text" ($comment "")) (br) 
	       ,(putin "text" (%u 0))
	       ((input :type "submit"))))))))
	  (request-redirect req "plist")))

(defhandler zlist3-handler? ((%o 0) (%l *limit*) %tran %t $w $c)
  (if (and %tran %t $w $c)
      (let ((p (corba-call #'op:phind *master* %tran)))
	(multiple-value-bind 
	      (rez1 rez2) 
	    (corba-call 
	     #'op:zlist *master* %t $w (op:id (op:first p)) %o (1+ %l))
	  (let* ((1p (1+ %l))
		 (len (length rez1))
		 (more (= 1p len))
		 (ws (if more (subseq rez1 0 %l) rez1))
		 (hts (if more (subseq rez2 0 %l) rez2)))
	    (write-html
	     req
	     `(html
	       (head 
		(title "Изменение перевода = Newid cyfieithiad")
		((link :rel "stylesheet" :type "text/css" 
					 :href "/geiriadur.css")))
	       (body
		(h1 "Изменение перевода = Newid cyfieithiad")
		"Исходный язык: " ,(cdr (assoc (op:lang (op:first p)) =langs=)) 
		(br) ,(op:id (op:first p)) " " 
		,@(word *entl* "w" (w>t (op:first p)))
		((a :href ,(format nil "cont?c=~a" $c)) "&larr;") (hr)
		(,@(lang-form "zlist3" $w :%t %t :%o %o :more more)
		   ,(putin "hidden" $c) 
		   ,(putin "hidden" %tran))
		((form :method "post" :action "pedit")
		 ,(putin "hidden" $c) 
		 ,(putin "hidden" %tran)
		 ,(putin "hidden" (%first (op:id (op:first p))))
		 ,@(apply 
		    #'append 
		    (map 'list 	
			 #'(lambda (w ht) 
			     (dizplay-word-3 (op:id (op:second p)) w ht))
			 ws hts))
		 ,(if (= %t (op:id (op:second p)))
		      (putin "radio" (%second %t) :checked)
		      (putin "radio" (%second %t)))
		 ((font :color "green") "Толкование") (br)
		 ,(putin "text" ($comment (html-escape (op:note p)))) (br)
		 ,(putin "text" (%u (op:usuality p)))
		 ((input :type "submit")))))))))
	  (request-redirect req "plist")))

;надо все это унифицировать...

(defcontinuation slist-proc (url name func typ %o %l %f $w %a %p %q)
  (let* ((1p (1+ %l))
	 (rez (corba-call 
	       #'op:list *master* typ %f $w (= %a 1) %p (= %q 1) %o 1p))
	 (len (length rez))
	 (more (= 1p len))
	 (page (if more (subseq rez 0 %l) rez)))
    (write-html
     req
     `(html
       (head 
	(title ,name)
	((link :rel "stylesheet" :type "text/css" :href "/geiriadur.css")))
       (body
	(h1 ,name)
	(,@(lang-form url $w :%f %f :%o %o :more more)
	   ,@(radioput %a "по словам" "по пометам")
	   ,(if (= %q 1)
		'((input :type "checkbox" :name "q" :value 1 :checked))
		'((input :type "checkbox" :name "q" :value 1)))
	   ,(list-box =parts= %p))
	,@(map 'list #'(lambda (b) (funcall func c/c b))
	       page)
	;(h2 "Новое = Newydd")
	;((form :method "post" :action "edit")
	; ,(putin "hidden" ($c c/c))
	; ,(putin "hidden" ($t typ))
	; ,(putin "hidden" (%op 0))
	; ,(putin "hidden" (%word 0))
	; ,(list-box =langs= (%lang %f))
	; ,(putin "text" ($val ""))
	; ,(list-box =parts= (%part 0))
	; ((span :class "t") "[" ,(putin "text" ($pron "")) "]")
	; ,(putin "text" ($attr ""))
	; ((input :type "submit")))
	)))))

;table lang mask attr prt pt offset count
  
(defhandler slist-handler? 
    ((%o 0) (%l *limit*) (%f 0) ($w "^а") (%a 1) (%p 0) (%q 0))
  (slist-proc req "slist" "Список слов = Rhestr eiriau" #'display-word :S
	      %o %l %f $w %a %p %q))

(defhandler elist-handler? 
    ((%o 0) (%l *limit*) (%f 0) ($w "^а") (%a 1) (%p 0) (%q 0))
  (slist-proc req "elist" "Список окончаний = Rhestr derfyniadau" 
	      #'display-ending :E %o %l %f $w %a %p %q))

(defcontinuation list-proc ($t %id $c)
  (write-html
   req
   `(html
     (head 
      (title ,(if (string= "f" $t) "Формы = Ffurfiau" "Корни = Gwreiddiau"))
      ((link :rel "stylesheet" :type "text/css" :href "/geiriadur.css")))
     (body
      (h1 ,(if (string= "f" $t) "Формы = Ffurfiau" "Корни = Gwreiddiau"))
      ((a :href ,(format nil "cont?c=~a" $c)) "&larr;")
      ,@(map 'list #'(lambda (p) (display-form $t c/c p))
	     (corba-call #'op:flist *master* %id (string= "f" $t)))
      ((form :method "post" :action "edit")
       ,(putin "hidden" ($c c/c))
       ,(putin "hidden" $t)
       ,(putin "hidden" (%op 0))
       ,(putin "hidden" (%word 0))
       ,(putin "hidden" (%lang 0))
       ,(putin "hidden" (%part %id))
       ,(putin "text" ($val ""))
       ((span :class "t") "[" ,(putin "text" ($pron "")) "]")
       ,(putin "text" ($attr ""))
       ((input :type "submit")))))))

(defhandler list-handler? ((%id 146089) ($t "f") $c)
  (list-proc req $t %id $c))

(defhandler edit-handler ((%op 1) $t %word %lang %part $val $pron $attr $c)
  (if (and $t %word %lang %part $val $pron $attr $c)
      (let ((w (dictionary:word
	       :id %word :lang %lang :prt %part :value $val
	       :attr $attr :pron $pron))
	    (tip (intern (string-upcase $t) :keyword)))
	(if (zerop %op)
	    (secure-corba-call req #'op:create *master* tip w t)
	    (secure-corba-call req #'op:edit *master* tip w))
	(funcall (gethash $c *continuations*) req))
      (request-redirect req "index")))

(defhandler pedit-handler ((%op 1) %tran %first %second $comment %u $c)
  (if (and %first %second $comment %u (or (and %tran $c) (zerop %op)))
      (if (zerop %op)
	  (progn
	    (secure-corba-call 
	     req #'op:pcreate *master* %first %second $comment %u)
	    (let ((1st (svref (corba-call #'op:paradigm *dict* %first) 0))
		  (2nd (svref (corba-call #'op:paradigm *dict* %second) 0)))
	      (plist-proc req 0 *limit* (op:lang 1st) (op:lang 2nd)
			  (format nil "^~a$" (op:value 1st)))))
	  (progn
	    (secure-corba-call
	     req #'op:pedit *master* %tran %first %second $comment %u)
	    (funcall (gethash $c *continuations*) req)))
      (request-redirect req "index")))

(defhandler destroy-handler? ($t %id $c)
  (if (and $t %id $c)
      (progn
	(apply
	 #'secure-corba-call
	 (cond
	   ((string= "f" $t) 
	    (list req #'op:destroy *master* :F %id))
	   ((string= "k" $t) 
	    (list req #'op:destroy *master* :K %id))
	   ((string= "e" $t) 
	    (list req #'op:destroy *master* :E %id))
	   ((string= "p" $t) 
	    (list req #'op:pdestroy *master* %id))
	   ((string= "x" $t) 
	    (list req #'op:xdestroy *master* %id))))
	(funcall (gethash $c *continuations*) req))
    (request-redirect req "index")))

;неэффективная и неатомарная функция
(defhandler shuffle-handler? (%tran %id %d $c)
  (if (and %tran %id %d $c)
      (let ((ee (corba-call #'op:xlist *master* %tran)))
	(let ((i (position %id ee :key #'op:id)))
	  (when i
	    (let ((j (if (zerop %d) (1+ i) (1- i))))
	      (when (and (>= j 0) (< j (length ee)))
		(setf (op:id (svref ee i)) (op:id (svref ee j)))
		(setf (op:id (svref ee j)) %id)
		(secure-corba-call req #'op:xedit *master* (svref ee i))
		(secure-corba-call req #'op:xedit *master* (svref ee j))))))
	(funcall (gethash $c *continuations*) req))
    (request-redirect req "index")))

(defhandler spcreate-handler? (%first %second $c)
  (if (and %first %second $c)
      (progn
	(secure-corba-call
	 req #'op:pcreate *master* %first %second "" 0)
	(funcall (gethash $c *continuations*) req))
      (request-redirect req "index")))

(defhandler cont-handler? ($c)
  (let ((func (gethash $c *continuations*)))
    (if func (funcall func req) (request-redirect req "index"))))	

(defhandler index-handler? ()
  (write-html
   req
   `(html
     (body
      ((a :href "dict") "Словарь = Geiriadur") (br)
      ((a :href "slist") "Список слов = Rhestr eiriau") (br)
      ((a :href "elist") "Список окончаний = Rhestr derfyniadau") (br)
      ((a :href "plist") "Список переводов = Rhestr gyfieithiadau")))))

(defhandler celt-handler? ()
      (request-redirect req "/"))

(defhandler login-handler? ((%s (random 1000000)))
  (if (gethash (request-cookie req "gookie") *cookies*)
      (request-redirect req "swyddfa/index")
      (write-html 
       req
       `(html
	 ((script :src "md5.js"))
	 (body
	  ((form :name "mor" :method "post" :action "morannon"
		 :onsubmit 
		 "mor.h.value=hex_md5(mor.n.value+mor.s.value+mor.h.value)")
	   ,(putin "hidden" %s)
	   (table
	    (tr (td "Имя пользователя") (td "Пароль") (td))
	    (tr (td ,(putin "text" ($n ""))) (td ,(putin "password" ($h "")))
		(td ((input :type "submit"))))
	    (tr (td "Enw defnyddiwr") (td "Cyfrinair") (td)))))))))

(defhandler mor-handler (%s $n $h)
  (let ((user (gethash $n *users*))
	(path (gethash %s *halen* "swyddfa/index")))
    (remhash %s *halen*)
    (if (and 
	 user (string= $h (md6 (format nil "~a~a~a" $n %s (luser-pass user)))))
	(progn
	  (setf 
	   (luser-salt user)
	   (ignore-errors (corba-call #'op:once *master* $n))) ;почему не utf8?
	  (let ((gookie (md5:md5sum-sequence (format nil "~a" user))))
	    (setf (gethash (format nil "~a" gookie) *cookies*) user)
	    (request-redirect req path 
			      :set-cookie (format nil "gookie=~a" gookie))))
	(request-redirect req "login"))))

(defclass edict-handler (dispatching-handler) ())

(defmethod handle-request-authentication 
  ((handler edict-handler) method request)
  (declare (ignore method))
  (let ((user (gethash (request-cookie request "gookie") *cookies*)))
    (if user (setf (request-user request) user)
      (let ((rnd (random 1000000)))
	(setf (gethash rnd *halen*) (request-url request))
	(request-redirect request (format nil "../login?s=~a" rnd))))))

(install-handler 
 (http-listener-handler *listener*)
 'dict-handler?
 (urlstring (merge-url *wrl* "dict")) nil)

(install-handler 
 (http-listener-handler *listener*)
 'paradigm-handler?
 (urlstring (merge-url *wrl* "paradigm")) nil)

(install-handler 
 (http-listener-handler *listener*)
 'mor-handler
 (urlstring (merge-url *wrl* "morannon")) nil)

(install-handler 
 (http-listener-handler *listener*)
 'login-handler?
 (urlstring (merge-url *wrl* "login")) nil)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 'static-file-handler :pathname "md5.js")
 (urlstring (merge-url *wrl* "md5.js")) t)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 'static-file-handler :pathname "geiriadur.css")
 (urlstring (merge-url *wrl* "geiriadur.css")) t)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 
  'static-file-handler 
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/priodoledd.html")
 (urlstring (merge-url *wrl* "priodoledd.html")) t)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 
  'static-file-handler 
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/disgrifiad-0.html")
 (urlstring (merge-url *wrl* "disgrifiad-0.html")) t)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 
  'static-file-handler 
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/disgrifiad-1.html")
 (urlstring (merge-url *wrl* "disgrifiad-1.html")) t)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 
  'static-file-handler 
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/disgrifiad-2.html")
 (urlstring (merge-url *wrl* "disgrifiad-2.html")) t)

(install-handler
 (http-listener-handler *listener*)
 (make-instance
  'static-file-handler
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/disgrifiad-3.html")
 (urlstring (merge-url *wrl* "disgrifiad-3.html")) t)

(install-handler
 (http-listener-handler *listener*)
 (make-instance
  'static-file-handler
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/disgrifiad-4.html")
 (urlstring (merge-url *wrl* "disgrifiad-4.html")) t)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 
  'static-file-handler 
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/disgrifiad.css")
 (urlstring (merge-url *wrl* "disgrifiad.css")) t)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 
  'static-file-handler 
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/ystadegau.html")
 (urlstring (merge-url *wrl* "ystadegau.html")) t)

(install-handler 
 (http-listener-handler *listener*)
 'celt-handler?
 (urlstring (merge-url *wrl* "index.html")) nil)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 
  'static-file-handler 
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/index.html")
 (urlstring (merge-url *wrl* "/")) t)

(install-handler 
 (http-listener-handler *listener*)
 (make-instance 
  'static-file-handler 
  :pathname "/usr/local/www/cymraeg.ru/www/geiriadur/index.html")
 (urlstring (merge-url *wrl* "")) t)

(install-handler
 (http-listener-handler *listener*)
'celt-handler?
(urlstring (merge-url *wrl* "/%20")) t) ;celtologica

(setf *edict* (make-instance 'edict-handler))

(install-handler 
 (http-listener-handler *listener*)
 *edict*
 (urlstring (merge-url *wrl* "swyddfa")) nil)

(install-handler *edict* 'index-handler? "" nil)
(install-handler *edict* 'index-handler? "/" nil)
(install-handler *edict* 'index-handler? "/index" nil)
(install-handler *edict* 'dict-handler? "/dict" nil)
(install-handler *edict* 'paradigm-handler? "/paradigm" nil)
(install-handler *edict* 'mpcreate-handler "/mpcreate" nil)
(install-handler *edict* 'plist-handler? "/plist" nil)
(install-handler *edict* 'xlist-handler? "/xlist" nil)
(install-handler *edict* 'cont-handler? "/cont" nil)
(install-handler *edict* 'xedit-handler "/xedit" nil)
(install-handler *edict* 'shuffle-handler? "/shuffle" nil)
(install-handler *edict* 'spcreate-handler? "/spcreate" nil)
(install-handler *edict* 'destroy-handler? "/destroy" nil)
(install-handler *edict* 'zlist1-handler? "/zlist1" nil)
(install-handler *edict* 'zlist2-handler? "/zlist2" nil)
(install-handler *edict* 'zlist3-handler? "/zlist3" nil)
(install-handler *edict* 'slist-handler? "/slist" nil)
(install-handler *edict* 'elist-handler? "/elist" nil)
(install-handler *edict* 'pedit-handler "/pedit" nil)
(install-handler *edict* 'edit-handler "/edit" nil)
(install-handler *edict* 'list-handler? "/list" nil)

(defun init ()
  (with-open-file (pr "priodoledd.lisp" :direction :input)
    (setf =langs= (read pr))
    (setf *parts* (read pr))
    (setf =parts= 
	  (loop for i below (array-dimension *parts* 0) 
	     collect (cons i (aref *parts* i 0))))
    (dolist (p (read pr)) (setf (gethash (svref p 0) *attrs*) p)))
  (connect-to-dictionary)
  (setf *random-state* (make-random-state t))
  (start-listening *listener*))
		 
;(host-serve-events)