#| 
   Macros for dictionary editing client 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.  
|#

(defpackage aranrod
   (:use common-lisp araneida))
(in-package aranrod)

(defmacro acond (&rest clauses)
  "Paul Graham. On Lisp, p.191"
  (if (null clauses)
      nil
    (let ((cl1 (car clauses))
	  (sym (gensym)))
      `(let ((,sym ,(car cl1)))
	 (if ,sym
	     (let ((it ,sym)) ,@(cdr cl1))
	   (acond ,@(cdr clauses)))))))

(defun condlet-binds (vars cl)
  "Paul Graham. On Lisp, p.146"
  (mapcar #'(lambda (bindform)
	      (if (consp bindform)
		  (cons (cdr (assoc (car bindform) vars))
			(cdr bindform))))
	  (cdr cl)))

(defun condlet-clause (vars cl bodfn)
  "Paul Graham. On Lisp, p.146"
  `(,(car cl) (let ,(mapcar #'cdr vars)
		(let ,(condlet-binds vars cl)
		  (,bodfn ,@(mapcar #'cdr vars))))))

(defmacro condlet (clauses &body body)
  "Paul Graham. On Lisp, p.146"
  (let ((bodfn (gensym))
	(vars (mapcar #'(lambda (v) (cons v (gensym)))
		      (remove-duplicates
		       (mapcar #'car
			       (apply #'append (mapcar #'cdr clauses)))))))
    `(labels ((,bodfn ,(mapcar #'car vars)
		      ,@body))
	     (cond ,@(mapcar #'(lambda (cl)
				 (condlet-clause vars cl bodfn))
			     clauses)))))

(defun hungarian (p)
  (let ((pn (string-downcase (symbol-name p))))
    (cond
     ((char= #\$ (schar pn 0)) (values (subseq pn 1) 'string))
     ((char= #\% (schar pn 0)) (values (subseq pn 1) 'fixnum))
     (t pn))))

(defgeneric get-query-param (name req))

(defmethod get-query-param (name (req araneida:request))
  (car (url-query-param (request-url req) name)))
;(defmethod get-query-param (name (req net.aserve:http-request))
;  (request-query-value name req))

(defgeneric post-query-param (name req))

(defmethod post-query-param (name (req araneida:request))
  (body-param name (request-body req)))

(defgeneric write-html (req html))

(defmethod write-html ((req araneida:request) html)
  (request-send-headers req :content-type "text/html;charset=UTF-8")
  (html-stream (request-stream req) html))
;  (signal 'response-sent))

(defmacro defhandler (fname parms &rest body)
  (let ((getter 
	 (if (char= #\? (schar (reverse (symbol-name fname)) 0))
	     'get-query-param
	   'post-query-param)))
    (flet 
     ((get-val 
       (p)
       (multiple-value-bind 
	(nname htype) (hungarian p)
	(case htype
	      (string
	       `(acond ((,getter ,nname req) (string-trim " " it))))
	      (fixnum
	       `(ignore-errors (parse-integer (,getter ,nname req))))
	      (t nil) ;подобно &aux
	      ))))
     `(defun ,fname (req) ;&optional ent)
	(let ,(mapcar
	       #'(lambda (p)
		   (if (atom p) `(,p ,(get-val p))
		       `(,(car p)
			  (cond (,(get-val (car p))) (t ,(second p))))))
	       parms)
	  (handler-case
	      (progn
		,@body)
	    (condition (c) (write-html req (format nil "~a" c)))))))))


(defun md6 (seq)
  (format nil "~{~2,'0X~}" (map 'list #'identity (md5:md5sum-sequence seq)))) 

(defmacro defcontinuation (fname parms &rest body)
   `(defun ,fname (req ,@parms)
      (let ((c/c 
	     (md6 
	      (clorb::string->octets
	       (format nil "(~@{~a ~})" ,(symbol-name fname) ,@parms)))))
	(setf (gethash c/c *continuations*) #'(lambda (r) (,fname r ,@parms)))
	,@body)))

(defmacro putin (type var &rest attrs)
  (if (atom var)
      (let ((name (hungarian var)))
	``((input :type ,,type :name ,,name :value ,,var ,,@attrs)))
      (let ((name (hungarian (car var))))
	``((input :type ,,type :name ,,name :value ,,(second var) ,,@attrs)))))

(defmacro radioput (var 1st 2nd)
  (if (atom var)
      (let ((name (hungarian var)))
	``(((input :type "radio" :name ,,name :value 1 
		   ,(if (= ,var 1) :checked))) ,,1st
	   ((input :type "radio" :name ,,name :value 0 
		   ,(if (= ,var 0) :checked))) ,,2nd))
      (let ((val (gensym)) (name (hungarian (car var))))
	`(let ((,val ,(second var)))
	   `(((input :type "radio" :name ,,name :value 1 
		     ,(if (= ,val 1) :checked))) ,,1st
	     ((input :type "radio" :name ,,name :value 0 
		     ,(if (= ,val 0) :checked))) ,,2nd)))))

(defmacro list-box (lst var)
  (if (atom var)
      (let ((nam (hungarian var)))
	``((select :name ,,nam :size 1)
	   ,@(mapcar
	      #'(lambda (l)
		  `((option :value ,(car l) ,(if (= ,var (car l)) :selected)) 
		    ,(cdr l)))
	      ,lst)))
      (let ((val (gensym)) (nam (hungarian (car var))))
	`(let ((,val ,(second var)))
	   `((select :name ,,nam :size 1)
	     ,@(mapcar
		#'(lambda (l)
		    `((option :value ,(car l) 
			      ,(if (= ,val (car l)) :selected)) 
		      ,(cdr l)))
		,lst))))))

(defmacro clink (((url &rest urgs) &rest attr) text)
  ``((a :href
	,,(if (not urgs)
	      url
	      `(format 
		nil 
		,(format 
		  nil "~~a?~{~a=~~a&~}" 
		  (mapcar 
		   #'(lambda (var) (hungarian (if (atom var) var (car var))))
		   urgs))
		,url
		,@(mapcar 
		   #'(lambda (var) (if (atom var) var (second var)))
		   urgs)))
	,,@attr)
     ,,text))