;;; -*- Mode: LISP; Package: :CL-USER; BASE: 10; Syntax: ANSI-Common-Lisp; -*- ;;; ;;; Touched: Sat Aug 06 00:12:16 2005 +0530 ;;; Time-stamp: <05/08/07 02:33:40 madhu> ;;; ;;; CGI under CMUCL for CL-HTTP. ;;; ;;; From "acl;obc;url,cgi.lisp" ;;; Prototype UNIX CGI access from CL-HTTP. ;;; Copyright (C) 1995 Olivier (OBC). ;;; All Rights Reserved. ;;; ;;;---------------------------------------------------------------------- ;;; ;;; URL definitions for UNIX CGI ;;; (in-package "URL") (export (mapcar (lambda (x) (intern x :url)) '("HTTP-UNIXCGI-PATH" "HTTP-UNIXCGI-OBJECT" "HTTP-UNIXCGI-SEARCHABLE-OBJECT" "MAKE-OBJECT-PATHNAME-NAME" "UNIXCGI-URL" "URL-SEARCH-STRING-P" "QUICK-SEARCH-PARENT"))) (defclass http-unixcgi-path (http-path) () (:documentation "URL path to a UNIX CGI script.")) (defclass http-unixcgi-object (http-object http-unixcgi-path) () (:documentation "Root class for standard http objects on the server.")) ;;; Bypass the general search mechanism of CL-HTTP ;;; (defclass http-unixcgi-searchable-object (http-unixcgi-object) ((search-string :initform nil :initarg :search-string)) (:documentation "Root class for standard http objects on the server.")) (defmethod search-parser ((url http-unixcgi-searchable-object)) #'(lambda (string &optional (start 0) end) (declare (ignore string start end)) (warn "search-parser lambda") nil)) (defmethod write-local-name ((url http-unixcgi-searchable-object) &optional stream) (write-path url stream) (write-char #\/ stream) (write-object-name-string url stream) (write-search url stream)) (defmethod write-search ((url http-unixcgi-searchable-object) &optional (stream *standard-output*)) (write-char *search-url-delimiter* stream) (with-slots (search-string) url (if search-string (write-string search-string stream)))) (defmethod make-object-pathname-name ((url http-unixcgi-object)) (with-slots (object extension) url (namestring (make-pathname :name object :type extension)))) (defvar *search-url-string* (make-string 1 :initial-element *search-url-delimiter*)) (defun url-search-string-p (string) (and (position *search-url-delimiter* string) t)) (defmethod nsubseq ((sequence array) (start fixnum) &optional (end (length sequence))) (locally (declare (optimize (speed 3) (safety 0)) (type fixnum start end)) (if (and (= start 0) (eql end (length (the simple-array sequence)))) sequence (make-array (- end start) :element-type (array-element-type sequence) :displaced-to sequence :displaced-index-offset start)))) (defun url-search-nsubseq (string) (let ((pos (position *search-url-delimiter* string))) (if pos (values (nsubseq string 0 (incf pos)) pos)))) (defun unixcgi-url (url &key ((:host host-string)) port pathname (start 0) (end (length url)) &allow-other-keys) (warn "pathname=~a" pathname) (let (object urlo extension path-index) ;; extract the host parameters (unless (and host-string port) (multiple-value-setq (host-string port path-index) (get-host-port-info url start end))) ;; extract the path components (multiple-value-bind (path object-index next-index search-p) (get-path-info url path-index end) ;; get the object components when present (when object-index (multiple-value-setq (object extension) (get-object-info url object-index next-index))) (cond (object (if search-p (setq urlo (make-instance 'http-unixcgi-searchable-object :host-string host-string :port port :path path :object object #+ignore (if extension object (concatenate 'string object *search-url-string*)) :search-string (subseq url (the fixnum (1+ next-index)) end) :extension extension #+ignore (if object extension (concatenate 'string extension *search-url-string*)))) (setq urlo (make-instance 'http-unixcgi-object :host-string host-string :port port :path path :object object :extension extension)))) (t (setq urlo (make-instance 'http-unixcgi-path :host-string host-string :port port :path path))))) (if pathname (setf (translated-pathname urlo) pathname)) (warn "set pathname=~a. urlo=~a" pathname urlo) urlo)) (defmethod quick-search-parent ((url string)) (multiple-value-bind (basearch position) (url-search-nsubseq url) (if (not (eq basearch url)) (values (get-url basearch #+gethash-nil *url-table*) position)))) (defmethod quick-search-parent ((url http-unixcgi-searchable-object)) (quick-search-parent (name-string url))) (defmethod quick-search-parent ((url http-unixcgi-object)) nil) ;;; ---------------------------------------------------------------------- (in-package "HTTP") ;;; We hit our head against CL-HTTP's assumption that all ;;; url must be pre-exported (even in *auto-export* mode) this ;;; conflicts with what we expect on UNIX, but it's much more secure? ;;; ;;; For now we expect the contents of the CGI-BIN and subdirectories ;;; to be exported once. We don't expect it to change later, this ;;; can be argued as a security measure. And we don't expect ;;; *auto-export* to work for CGI-BIN objects. Since we don't need ;;; the extra search processing provided by HTTP-SEARCH, we define ;;; a set of raw search objects for UNIXCGI and response methods ;;; that escape to UNIX shell. ;;; ;;; Examples: ;;; ;;; (export-url "/cl-http/cgi-bin/" :unixcgi :pathname (pathname "http:acl;cgi-bin;") :redefine t) ;;; ;;; accessing the following URLs will provide minimum testing: ;;; http://you.machine.site.edu/cl-http/cgi-bin/date ;;; http://you.machine.site.edu/cl-http/cgi-bin/test ;;; http://you.machine.site.edu/cl-http/cgi-bin/test? ;;; http://you.machine.site.edu/cl-http/cgi-bin/test?foo=1&bar=1 ;;; http://you.machine.site.edu/cl-http/cgi-bin/mfortune.pl?pattern=foo ;;; ;;; If you add cgi scripts in "http:acl;cgi-bin;" you need to reevaluate ;;; the above definition to test them. ;;; (defmethod export-type ((url url:http-unixcgi-path)) :unixcgi) (defmethod translation-method ((url url:http-unixcgi-path)) :unixcgi) (defmethod export-url ((url string) (translation (eql :unixcgi)) &rest args) (let (mainurl (pathname (getf args :pathname))) (setq pathname (translate-logical-pathname pathname)) (setf (getf args :pathname) pathname) (setq mainurl (apply #'url:unixcgi-url (merge-url url (local-context)) args)) (cond ((getf args :redefine) (url::unregister (url::register mainurl t)) (setq mainurl (url::register mainurl nil))) (t (setq mainurl (url::register mainurl t)))) (when (pathname-directory-p pathname) (loop with fullname for path in (directory-list* pathname nil :directories) as name = (pathname-name path) as type = (pathname-type path) when (or type name) do (setq fullname (namestring (make-pathname :name name :type type :directory (cons :absolute (slot-value mainurl 'url::path))))) (apply #'export-url fullname :unixcgi :pathname path args) (unless (or (url:url-search-string-p fullname) (pathname-directory-p path)) (apply #'export-url (concatenate 'string fullname url::*search-url-string*) :unixcgi :pathname path args)))) mainurl)) ;;; ;;; UNIX CGI PARENT SEARCH AND MUTATOR ;;; (defmethod reuse-registered-search-object (url url-string position) (declare (ignore url url-string position))) (defmethod reuse-registered-search-object ((url url:http-unixcgi-searchable-object) url-string position) (declare (ignore position)) (url:unixcgi-url (merge-url url-string (local-context)))) (defmethod mutate-pre-exported-search-url ((url-string string)) (multiple-value-bind (parent position) (url:quick-search-parent url-string) (if parent (reuse-registered-search-object parent url-string position)))) ;;; ;;; UTILITIES ADAPTED FOR UNIX RESPONSES: ;;; (defvar *cgi-bindings* (get-cgi-variable-bindings (all-cgi-variables))) ;;; OVERLOADING FOR UNIXCGI ;;; Note that the default HTTP scheme parser can easily ;;; be extended. So the parser will construct and HTTP-SEARCH ;;; object, however we tricked the translation to be :UNIXCGI ;;; we can now patch the scheme parse final effect here. ;;; (defmethod write-document ((url url:http-search) (translation (eql :unixcgi)) stream) (let ((originalsearch (server-url-string *server*))) (write-document (mutate-pre-exported-search-url originalsearch) translation stream))) (defvar *unix-shell-illegals* ";& ()|%?*<> {}$@![]'\"`#") (defun unix-shell-validation (name url &optional (url-string (url:name-string url))) (if (find-if #'(lambda (c) (find c *unix-shell-illegals*)) name) (error 'bad-syntax-provided :url url :format-string "No form values were returned for UNIX CGI ~A." :format-args (list url-string)))) ;;; ;;; UNIX CGI METHODS SUPPORTED ;;; (defun environment-unix-cgi-vars (server &rest keyvals) (loop for (var def) in *cgi-bindings* as val = (getf keyvals var) unless val do (typecase def ((and symbol (not null)) (setq val (symbol-value def))) (cons (setq val (apply (first def) (subst server '*server* (rest def))))) (t (setq val def))) collect (cons (intern (symbol-name var) :keyword) (or (and val (etypecase val (string val) (symbol (symbol-name val)) (integer (format nil "~d" val)))) "")))) (defmethod write-document ((urlo url:http-unixcgi-object) translation stream) (declare (ignore translation)) (let ((url (server-url-string *server*)) (method :get)) (let ((pos? (position url::*search-url-delimiter* url)) name (shargs "") cmd (args "")) (setq name (url:make-object-pathname-name urlo)) (unix-shell-validation name urlo url) (if pos? (setq args (subseq url (1+ pos?)))) (unless (find #\= args) (setq shargs args args "")) (warn "write-document: cmd = ~a" cmd) #+nil (setq cmd (namestring (url:translated-pathname (or (url:quick-search-parent urlo) urlo)))) ;; cmucl error: cannot namestring on pathname with host nil (setq cmd (namestring (identity (url:translated-pathname (or (url:quick-search-parent urlo) urlo))))) (let (proc) (unwind-protect (setq proc (EXT:run-PROGRAM "/bin/sh" (list "-c" cmd ) :input nil :output :stream :wait t :env (environment-unix-cgi-vars *server* :script_name name :request_method method :query_string args :path nil) )) (when proc (let ((ustream (ext:PROCESS-OUTPUT proc))) (progn (report-status-success stream) (stream-copy-until-eof ustream stream)) #+nil (with-successful-response (stream :html) (stream-copy-until-eof ustream stream)) (close ustream) (ext:process-close proc) t))))))) (defmethod post-document ((urlo url:http-unixcgi-object) type subtype stream) (declare (ignore type subtype)) (let ((url (server-url-string *server*)) (method :post)) (let (name cmd) (setq name (url:make-object-pathname-name urlo)) (unix-shell-validation name urlo url) (setq cmd (namestring (url:translated-pathname urlo))) (let (proc) (unwind-protect (setq proc (EXT:run-PROGRAM "/bin/sh" (list "-c" cmd) :input nil :output :stream :wait t :env (environment-unix-cgi-vars *server* :script_name name :request_method method :content_length (get-header :context-length) :path nil) )) (when proc (let ((ustream (ext:PROCESS-OUTPUT proc))) (progn (report-status-success stream) (stream-copy-until-eof ustream stream)) #+nil (with-successful-response (stream :html) (stream-copy-until-eof ustream stream)) (close ustream) (ext:process-close proc) t))))))) ;;; ---------------------------------------------------------------------- ;;; ;;; Patch server.lisp ;;; ;;; ;;; madhu 050816: patch invoke-server-method instead of frobbing ;;; translated-method, valid-search-url-p and dispatching around (sic) ;;; write-document on http-searchable-object (which object is what ;;; parse-url creates for invoke-server-method on encountering a ;;; cgi-bin url). (defmethod invoke-server-method ((server basic-server-mixin) (method (eql :get)) (http-version symbol)) (macrolet ((handle-redirect (condition tag) `(destructuring-bind (target-url &rest other-urls) (new-urls ,condition) (cond ;; optimize redirect by reinvoking for singleton local url. ((and (null other-urls) (local-redirect-p target-url)) (setf (server-url-string server) (url:name-string target-url)) (go ,tag)) (t (report-status ,condition stream)))))) (with-slots (stream url-string) server (warn " (url:valid-search-url-p url-string=~a) ~a" url-string (url:valid-search-url-p url-string)) (prog ((search-url-p (url:valid-search-url-p url-string)) (cgi-parent (multiple-value-bind (basearch position) (url::url-search-nsubseq url-string) (if basearch (url::get-url basearch)))) translation-method) retry1 (handler-case (multiple-value-bind (url) (if (and cgi-parent (typep cgi-parent 'url::http-unixcgi-object)) (with-slots (pathname) cgi-parent (unixcgi-url url-string :pathname pathname)) (url:intern-url url-string :if-does-not-exist (if search-url-p *search-url-intern-mode* :soft))) (tagbody retry2 (cond (url (cond ((setq translation-method (or (translation-method url) (and *auto-export* (auto-export-pathname-url url-string) (translation-method url)))) (setf (server-url server) url) (with-access-control (url method server (or (url:secure-subnets url) *secure-subnets*) :deny-subnets *disallowed-subnets*) (server-update-url-specific-timeouts server url) (write-document url translation-method stream))) (t (error 'document-not-found :url url :method :get)))) ((and (not search-url-p) *auto-export* (auto-export-pathname-url url-string)) (go retry1)) ((setq url (locate-controlling-url url-string method search-url-p)) (go retry2)) (t (error 'document-not-found :url (or url url-string) :method :get))))) (redirection (cond) (handle-redirect cond retry1))))))) ;;; ---------------------------------------------------------------------- ;;; ;;; export *after* enabling server (and setting up local context). ;;; ;;; madhu 050806non-mp CMUCL hangs somewhere on serve-event. #+nil (export-url "/cl-http/cgi-bin/" :unixcgi :pathname #p"/home/madhu/cgi-bin/" :redefine t) #+ignore (mapcar #'unintern-url (let (urls) (url:map-url-table (lambda (x y) (push y urls))) urls) ) #+ignore (setq $b (let (urls) (url:map-url-table (lambda (x y) (push y urls))) urls))(cl:in-package :http)