#| 
   Dictionary editor implementation.
   
   Author: Dmitri Hrapof <yavannadil@yahoo.com>
   Version: 0.4
   Copyright (C) 2004, 2005 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 geiriadur)

;;;<global>

(defparameter *conn* nil)

(defparameter *users* (make-hash-table :test #'equal))

;;;<security>

(defstruct luser pass rand)

(defun authorize (user digest)
  (let ((p (gethash user *users*)))
    (if p
	(if (not 
	     (mismatch 
	      (md5:md5sum-sequence 
	       (format nil "~a~d~a" user (luser-rand p) (luser-pass p)))
	      digest))
	    t
	  (progn 
	    (setf (luser-rand p) (random 1000000))
	    (error 'Dictionary:NoPermission)))
      (error 'Dictionary:NoPermission))))
      
(defun nonce (user)
  (let ((p (gethash user *users*)))
    (if p (setf (luser-rand p) (random 1000000))
      (error 'Dictionary:NoPermission))))

(defmacro with-authorization (user digest &rest body)
  `(let ((*log-sql* t))
     (authorize ,user ,digest)
     (format t "~a ~a " (multiple-value-list (get-decoded-time)) user)
     (let ((result (progn ,@body)))
       (if result (values result (nonce ,user)) (nonce ,user)))))

;;;<sql>

(defun count-sql (lang letter limit) ;надо эти два метода убить, что ли?
  (format nil "select count(id) from soroca where val ~~ ~/gdr:stroqa/ and val < ~/gdr:stroqa/ and lang = ~a" letter limit lang))

(defun pcount-sql (from to letter limit)
  (format nil "select count(p.id) from p, s, s as ss where p.first = s.id and p.second = ss.id and s.val ~~ ~/gdr:stroqa/ and s.val < ~/gdr:stroqa/ and s.lang = ~a and ss.lang = ~a" letter limit from to))

(defun xlist-sql (tran)
  (format nil "select id, tran, first, second from x where tran = ~a order by id" tran))

(defun plist-sql (from to mask offset count)
;  (format nil "select p.id, s.id, s.lang, s.part, s.val, s.attr, s.pron, ss.id, ss.lang, ss.part, ss.val, ss.attr, ss.pron, p.comment, p.usuality, px.count, py.dip from p, px, py, s, s as ss where p.id = px.pid and p.id=py.pid and p.first = s.id and p.second = ss.id and s.lang = ~a and ss.lang = ~a and s.val ~~ ~/gdr:stroqa/ order by s.val,s.id,p.usuality limit ~a offset ~a" from to mask count offset))
  (format nil "select 0, s.id, s.lang, s.part, s.val, s.attr, s.pron, 0, ~a, 0, null, null, null, null, 0 as usuality, 0, null from s where s.id in (select s.id from s where s.lang = ~a and s.val ~~ ~/gdr:stroqa/ except select s.id from p, s, s as ss where p.first = s.id and p.second = ss.id and s.lang = ~a and ss.lang = ~a and s.val ~~ ~/gdr:stroqa/) 
union 
select p.id, s.id, s.lang, s.part, s.val, s.attr, s.pron, ss.id, ss.lang, ss.part, ss.val, ss.attr, ss.pron, p.comment, p.usuality, px.count, py.dip from p, px, py, s, s as ss where p.id = px.pid and p.id=py.pid and p.first = s.id and p.second = ss.id and s.lang = ~a and ss.lang = ~a and s.val ~~ ~/gdr:stroqa/ 
order by val,id,usuality
limit ~a offset ~a" to from mask from to mask from to mask count offset))

(defun phind-sql (tran)
  (format nil "select p.id, s.id, s.lang, s.part, s.val, s.attr, s.pron, ss.id, ss.lang, ss.part, ss.val, ss.attr, ss.pron, p.comment, p.usuality, px.count from p, px, s, s as ss where p.id = ~a and p.id = px.pid and p.first = s.id and p.second = ss.id" tran))

(defun flist-sql (word f/k)
  (format nil "select ~a.id, s.lang, s.part, ~a.val, ~a.attr, ~a.pron from ~a, s where ~a.word = s.id and s.id = ~a order by ~a.val" f/k f/k f/k f/k f/k f/k word f/k))

(defun list-sql (tn lang mask part offset count)
  (format nil "select id, lang, part, val, attr, pron from ~a where lang = ~a and val ~~ ~/gdr:stroqa/ ~@[and part = ~a~] order by val,attr limit ~a offset ~a" tn lang mask part count offset))

(defun slist-sql (lang mask part offset count)
  (format nil "select id, lang, part, val, attr, pron from s where id in (select id from s where lang = ~a and attr ~~ ~/gdr:stroqa/ union select word from f,s where s.id=f.word and s.lang = ~a and f.attr ~~ ~/gdr:stroqa/ union select word from k,s where s.id=k.word and s.lang = ~a and k.attr ~~ ~/gdr:stroqa/) ~@[and part = ~a~] order by attr, val limit ~a offset ~a" lang mask lang mask lang mask part count offset))

(defun elist-sql (lang mask part offset count)
  (format nil "select id, lang, part, val, attr, pron from e where lang = ~a and attr ~~ ~/gdr:stroqa/ ~@[and part = ~a~] order by attr, val limit ~a offset ~a" lang mask part count offset))

(defun zlist-sql (lang mask word offset count)
  (format nil "select s.id, lang, part, val, attr, pron, count(p.id) from s left join p on s.id = p.second and p.first = ~a where lang = ~a and val ~~ ~/gdr:stroqa/ group by s.id, lang, part, val, attr, pron order by val limit ~a offset ~a" word lang mask count offset))

(defun destroy-sql (tn id)
  (format nil "delete from ~a where id = ~a" tn id))

(defun create-sql (tn lang w/p val attr pron check)
  (format nil "select ~acreate (~a, ~a, ~/gdr:stroqa/, ~/gdr:stroqa/, ~/gdr:stroqa/, ~a)" tn lang w/p val attr pron (if check "true" "false")))

(defun pcreate-sql (first second comment usuality)
  (format nil "select pcreate (~a, ~a, ~/gdr:stroqa/, ~a)" 
	  first second comment usuality))

(defun xcreate-sql (tran first second)
  (format nil "select xcreate (~a, ~/gdr:stroqa/, ~/gdr:stroqa/)" tran first second))

(defun sedit-sql (tn id lang part val attr pron)
  (format nil "update ~a set lang = ~a, part = ~a, val = ~/gdr:stroqa/, attr = ~/gdr:stroqa/, pron = ~/gdr:stroqa/ where id = ~a" tn lang part val attr pron id))

(defun eedit-sql (tn id lang part val attr pron)
  (format nil "update ~a set lang = ~a, part = ~a, val = coalesce(~/gdr:stroqa/,''), attr = ~/gdr:stroqa/, pron = ~/gdr:stroqa/ where id = ~a" tn lang part val attr pron id))

(defun fedit-sql (tn id val attr pron)
  (format nil "update ~a set val = ~/gdr:stroqa/, attr = ~/gdr:stroqa/, pron = ~/gdr:stroqa/ where id = ~a" tn val attr pron id))

(defun pedit-sql (id first second comment usuality)
  (format nil "update p set first = ~a, second = ~a, comment = ~/gdr:stroqa/, usuality = ~a where id = ~a" first second comment usuality id))

(defun xedit-sql (id first second)
  (format nil "update x set first = ~/gdr:stroqa/, second = ~/gdr:stroqa/ where id = ~a" first second id))

;;;<pg>

(defun convert-pg-error (pe)
  (format *error-output* "converted ~a~%" pe)
  (make-condition 'Dictionary:InternalError))

;;;<servant>

(defclass workshop-impl (dictionary:workshop-servant) ())

(corba:define-method 
 count ((self workshop-impl) lang letter limit)
 (let ((rs (db-call *conn* (count-sql lang letter limit))))
   (if rs (caar rs) 0)))
 
(corba:define-method 
 pcount ((self workshop-impl) from to letter limit)
 (let ((rs (db-call *conn* (pcount-sql from to letter limit))))
   (if rs (caar rs) 0)))

(corba:define-method 
 list ((self workshop-impl) table lang mask attr prt pt offset count)
  (mapcar 
   #'tow 
   (db-call *conn*
    (if attr (list-sql (symbol-name table) lang mask (if pt prt) offset count)
	(case table
	  ((:S) (slist-sql lang mask (if pt prt) offset count))
	  ((:E) (elist-sql lang mask (if pt prt) offset count)))))))

(corba:define-method 
 zlist ((self workshop-impl) lang mask word offset count)
 (let ((wl ()) (bl ()))
   (dolist 
       (tuple (db-call *conn* (zlist-sql lang mask word offset count)))
     (push (tow tuple) wl) (push (= 1 (seventh tuple)) bl))
   (values (reverse wl) (reverse bl))))

 
(corba:define-method 
 flist ((self workshop-impl) word fork)
 (mapcar #'tow (db-call *conn* (flist-sql word (if fork "f" "k")))))
 
(defun tot (tup)
  (dictionary:translation
   :id (first tup)
   :first (tow (cdr tup))
   :second (tow (nthcdr 7 tup))
   :note (nth 13 tup)
   :usuality (nth 14 tup)
   :usage (list (dictionary:example :id (nth 15 tup))
		(dictionary:example :id (if (nth 16 tup) 1 0)))))

(corba:define-method 
 plist ((self workshop-impl) from to mask offset count)
 (mapcar #'tot (db-call *conn* (plist-sql from to mask offset count))))

(corba:define-method 
 phind ((self workshop-impl) tran)
  (let ((rs (db-call *conn* (phind-sql tran))))
    (if rs (tot (car rs)) (error 'Dictionary:NotFound))))

(corba:define-method 
 xlist ((self workshop-impl) tran)
 (mapcar #'toe (db-call *conn* (xlist-sql tran))))

(corba:define-method 
 once ((self workshop-impl) user)
 (nonce user))

(corba:define-method 
 destroy ((self workshop-impl) table id user digest)
 (with-authorization 
     user digest (db-call *conn* (destroy-sql (symbol-name table) id))))

(corba:define-method 
 pdestroy ((self workshop-impl) id user digest)
 (with-authorization user digest (db-call *conn* (destroy-sql "p" id))))

(corba:define-method 
 xdestroy ((self workshop-impl) id user digest)
 (with-authorization user digest (db-call *conn* (destroy-sql "x" id))))

(corba:define-method 
 create ((self workshop-impl) table word check user digest)
 (with-authorization 
  user digest
  (let ((ret 
	 (caar 
	  (db-call *conn* 
	   (create-sql 
	    (symbol-name table) 
	    (op:lang word) (op:prt word) 
	    (op:value word) (op:attr word) (op:pron word) check)))))
    (if (< ret 0) (error 'Dictionary:Oes) ret))))

(corba:define-method 
 pcreate ((self workshop-impl) fst sec com usu user digest)
 (with-authorization 
  user digest
  (let ((ret (caar (db-call *conn* (pcreate-sql fst sec com usu)))))
    (if ret (if (< ret 0) (error 'Dictionary:Oes) ret)))))

(corba:define-method 
 xcreate ((self workshop-impl) ex user digest)
 (with-authorization 
  user digest 
  (caar (db-call *conn* (xcreate-sql (op:id ex) (op:first ex) (op:second ex))))))

(corba:define-method 
 edit ((self workshop-impl) table word user digest)
 (with-authorization 
  user digest
  (db-call *conn* (case table
	      ((:S)
	       (sedit-sql (symbol-name table) (op:id word)
			  (op:lang word) (op:prt word) 
			  (op:value word) 
			  (op:attr word) 
			  (op:pron word)))
	      ((:B :E)
	       (eedit-sql (symbol-name table) (op:id word)
			  (op:lang word) (op:prt word) 
			  (op:value word) 
			  (op:attr word) 
			  (op:pron word)))
	      ((:F :K) 
	       (fedit-sql (symbol-name table) (op:id word)
			  (op:value word) 
			  (op:attr word) 
			  (op:pron word)))))))

(corba:define-method 
 pedit ((self workshop-impl) id fst sec com usu user digest)
 (with-authorization user digest (db-call *conn* (pedit-sql id fst sec com usu))))

(corba:define-method 
 xedit ((self workshop-impl) ex user digest)
 (with-authorization 
     user digest 
     (db-call *conn* (xedit-sql (op:id ex) (op:first ex) (op:second ex)))))

;;;<main>

(defun do-work ()
  (setf clorb::*log-level* 100)
  (setf *random-state* (make-random-state t))
  (pushnew (cons 'pg::postgresql-error #'convert-pg-error) 
	 clorb::*condition-converters*)
  (db-init t)
  (let ((orb (CORBA:ORB_init (list "-ORBPort" "2629")))
	(srv (make-instance 'workshop-impl))
	(gdr (make-instance 'lookup-impl)))
    (let ((poa (op:resolve_initial_references orb "RootPOA")))
      (op:activate_object poa srv)
      (op:activate_object poa gdr)
      (op:activate (op:the_poamanager poa))
      (with-open-file 
       (wr "gweithdy.ior" :direction :output :if-exists :supersede)
       (format wr "~A~%" 
	       (op:object_to_string orb (op:servant_to_reference poa srv))))
      (with-open-file 
	(wr "geiriadur1.ior" :direction :output :if-exists :supersede)
	(format wr "~A~%" 
		(op:object_to_string orb (op:servant_to_reference poa gdr)))))
    #+sbcl
    (clorb::make-repl-happy)
    (handler-bind 
	((error 
	  (lambda (c)
	    (let ((*debug-io* *standard-output*))
	      (format *debug-io* "~%~a~%" c) 
	      #+sbcl (sb-debug:backtrace)
	      (finish-output *debug-io*))
	    (throw 'aga nil))))
      (loop do
	   (catch 'aga
	     (op:run orb))))))