[ginseng-cvs] CVS ginseng/src

[wchunye]

Update of /project/ginseng/cvsroot/ginseng/src
In directory cl-net:/tmp/cvs-serv29557/src

Added Files:
	.cvsignore application.lisp dispatcher.lisp my-utils.lisp 
	package.lisp pattern-match.lisp 
Log Message:
initial version.



--- /project/ginseng/cvsroot/ginseng/src/.cvsignore	2010/08/09 12:27:25	NONE
+++ /project/ginseng/cvsroot/ginseng/src/.cvsignore	2010/08/09 12:27:25	1.1
*.wx32fsl
*.fasl--- /project/ginseng/cvsroot/ginseng/src/application.lisp	2010/08/09 12:27:26	NONE
+++ /project/ginseng/cvsroot/ginseng/src/application.lisp	2010/08/09 12:27:26	1.1
(in-package :ginseng)
(defparameter *k* nil)
(defmacro dynamic-url (&body body)
  (hunchentoot::with-unique-names
      (next)
    `(let ((,next (make-unique-id)))
       (setf (gethash ,next *k*)
             #'(lambda ()
                 , at body))
       (relative-url-to-app :args (list ,next)))))
(defun relative-url-to-app (&key 
                            (prefix *ginseng-prefix*)
                            (package (package-name *package*))
                            (app *ginseng-app-name*)
                            (args))
  (format nil "~{~A~^/~}" 
          (append (list prefix package app) args)))

(defun invoke-next-action (next-action &optional (main #'identity))
  (let ((*k* (or (session-value 'k) (make-hash-table :test #'equal))))
    (setf (session-value 'k) *k*)
    (funcall (gethash next-action *k* 
                      main))))


(defun get-parameter (id type &optional (method :both))
  (hunchentoot::compute-parameter id type method))

(defstruct callback-factory callbacks)
(defun create-callback (cf func
                        &key
                        (type 'string)
                        (call-when-parameter-not-exists nil))
  (let ((id (make-unique-id)))
    (push 
     (if call-when-parameter-not-exists
         #'(lambda ()
             (funcall func (get-parameter id type)))
         #'(lambda ()
              (let ((v (get-parameter id type)))
                (if v (funcall func v)))))
     (callback-factory-callbacks cf))
     id))
(defun apply-callbacks(cf)
  (dolist (f (callback-factory-callbacks cf))
    (funcall f)))--- /project/ginseng/cvsroot/ginseng/src/dispatcher.lisp	2010/08/09 12:27:26	NONE
+++ /project/ginseng/cvsroot/ginseng/src/dispatcher.lisp	2010/08/09 12:27:26	1.1
(in-package :ginseng)

(defvar *last-request* nil
  "the last REQUEST object. it is used for debuging and testing")
(defvar *ginseng-acceptor* nil
  "the ACCEPT object")
(defvar *ginseng-prefix* "/cgi-bin"
  "default prefix for the framework.")
(defvar *ginseng-app-name* nil)
(defmacro with-last-environment (&body body)
  `(let* ((ginseng::*last-request* ginseng::*last-request*)
          (hunchentoot::*request* ginseng::*last-request*)
         (hunchentoot::*acceptor* (hunchentoot:request-acceptor ginseng::*last-request*))
          (hunchentoot::*session* (hunchentoot:session-verify ginseng::*last-request*)))
     , at body))
(defun ginseng-dispacher ()
  (setq *last-request* *request*)
  (let ((script-name  (script-name*)) )
    (when (search *ginseng-prefix* script-name)
      (aprogn
       (subseq script-name (length *ginseng-prefix*))
       (split-sequence:split-sequence #\/ it) ; split via "/"
       (delete "" it  :test #'string=)  ; delete the empty string.
       (let* ((list it)
              (package-name (nth 0 it))
              (app-name (nth 1 it))
              (args (nthcdr 2 list))
              (package (find-package (string-upcase package-name)))
              (function-symbol (and package 
                                    (find-symbol (string-upcase 
                                                  (concatenate 'string "http-" app-name))
                                                 package)))
              (*package* (or package *package*))
              (*ginseng-app-name* app-name)
              )
         (my-debug "access ~A" script-name)
         (if (fboundp function-symbol)
             (apply function-symbol args)
             (progn 
               (my-debug "APP NOT FIND:~A" (list package-name app-name package function-symbol))
               nil))
         )))))
(let (prefix-dispatcher-func)
  (defun start-server(&key (port 4242))
    (setq *ginseng-acceptor* (make-instance 'acceptor 
                                            :port port))
    (setq hunchentoot:*show-lisp-errors-p* t)
    (push
     (setf prefix-dispatcher-func
           (create-prefix-dispatcher *ginseng-prefix* 'ginseng-dispacher))
     *dispatch-table*)
    (start *ginseng-acceptor*))
  (defun stop-server()
    (stop *ginseng-acceptor*)
    (setq *dispatch-table*
          (remove prefix-dispatcher-func *dispatch-table*))
    (setq *ginseng-acceptor* nil)))
--- /project/ginseng/cvsroot/ginseng/src/my-utils.lisp	2010/08/09 12:27:26	NONE
+++ /project/ginseng/cvsroot/ginseng/src/my-utils.lisp	2010/08/09 12:27:26	1.1
(in-package :ginseng)

(defvar it nil)
(defmacro aprogn (&rest body)
  `(let ((it (and (boundp 'it) it)))
     ,@(mapcar #'(lambda (s)
                   `(setq it ,s))
               body)
     it))
(defmacro awhen (test &rest body)
  `(let ((it (and (boundp 'it) it)))
     (when (setq it ,test)
       ,@(mapcar #'(lambda (s)
                     `(setq it ,s))
                 body)
       it)))

(let ((output *standard-output*))
  (defun my-debug (&rest args)
    (format output "~&WCY-DEBUG:")
    (apply #'format output args))) 

(defun make-unique-id ()
  (hunchentoot::md5-hex
   (hunchentoot::create-random-string 10 36)))--- /project/ginseng/cvsroot/ginseng/src/package.lisp	2010/08/09 12:27:26	NONE
+++ /project/ginseng/cvsroot/ginseng/src/package.lisp	2010/08/09 12:27:26	1.1
(in-package :cl-user)
(defpackage :ginseng
  (:use :cl :iterate)
  (:export :my-debug :aprogn :it :start-server :stop-server
           :dynamic-url
           :relative-url-to-app
           :invoke-next-action
           :make-callback-factory
           :create-callback
           :apply-callbacks
           )
  (:import-from :hunchentoot 
                :*dispatch-table* 
                :create-prefix-dispatcher
                :start
                :stop
                :acceptor
                :script-name*
                :*request*
                :session-value
                :get-parameters*
                :post-parameters*
                ))
--- /project/ginseng/cvsroot/ginseng/src/pattern-match.lisp	2010/08/09 12:27:26	NONE
+++ /project/ginseng/cvsroot/ginseng/src/pattern-match.lisp	2010/08/09 12:27:26	1.1
(in-package :ginseng)
(defun generate-code (pattern in body)
  (cond
    ((null pattern)
     `(if (null ,in)
           ,body))
    ((consp pattern)
     (let ((next-car (gensym))
           (next-cdr (gensym)))
       
     `(if (consp ,in)
           (let ((,next-car (car ,in))
                 (,next-cdr (cdr ,in)))
             (declare (ignorable ,next-car ,next-cdr))
             ,(generate-code (car pattern) next-car
                              (generate-code (cdr pattern) next-cdr body))))))
    ((symbolp pattern)
     `(let ((,pattern ,in))
        (declare (ignorable ,pattern))
        ,body)
     )))
(defmacro p(pattern)
  (let ((input (gensym)))
    `#'(lambda (,input)
         ,(generate-code pattern input t))))
(defun match-helper (expr test-body)
  (if (null test-body) nil
      (let ((ok (gensym))
            (v (gensym))
            (tmp-args (gensym)))
        `(multiple-value-bind (,ok ,v)
             (funcall 
              #'(lambda (,tmp-args) 
                  ,(generate-code (caar test-body)
                                  tmp-args (append (list 'values t) (cdar test-body))))
              ,expr)
           (if ,ok
               ,v
               ,(match-helper expr (cdr test-body)))))))
(defmacro match (expr test-body)
  (let ((expr-v (gensym)))
    `(let ((,expr-v ,expr))
       ,(match-helper expr-v test-body))))