;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*- ;;; ;;; Touched: Sat Aug 13 12:35:53 2005 +0530 ;;; Time-stamp: <05/08/15 15:04:29 madhu> ;;; Bugs-To: ;;; Status: Experimental ;;; ;;; Integrate Interfaces to OpenSSL and (OpenSSL public key based) ;;; SPKI certificate management into a CL-HTTP web application. ;;; (defpackage "SSL-CA" (:use "CL") (:export)) (in-package "SSL-CA") (defparameter sslca-url #u"/sslca/begin.html" "The SSL CA CL-HTTP Web application home page.") (defparameter index-section-urls nil "URL variables that are listed in the index section of the home page.") (pushnew 'sslca-url index-section-urls) (defun write-sslca-anchor (stream) (html:new-paragraph :stream stream) (html:note-anchor "[Home]" :reference sslca-url :stream stream)) ;;; ;;; Extend W3P to handle CLOS objects automatically. Make your CLOS ;;; objects subclass PRESENTATION-TYPE-OBJECT, metaclass ;;; PRESENTATION-TYPE-METACLASS, and they can be automatically ;;; presented and read from CL-HTTP forms. ;;; (define-condition bad-user-input (http::bad-syntax-provided) ((reason :initform "User Input Not of Required Type") (response :initform nil :initarg :response)) (:documentation "Signalled when invalid user input is encountered.")) (defun report-invalid-input (url query-id presentation-type raw-value &optional (plural-count 1)) (cond (raw-value (error 'bad-user-input :url url :format-string "The value of ~A was ~S, which is not ~A. Please use the back button on your browser and try again." :format-args (list query-id raw-value (w3p:describe-presentation-type presentation-type nil plural-count)))) (t (error 'bad-user-input :url url :format-string "No value was supplied for ~A. Please use the back button on your browser and try again." :format-args (list query-id))))) ;;; ;;; severe horrible overloading of |PRESENTATION TYPE| ;;; (defclass presentation-type-metaclass (standard-class) () (:documentation "Metaclass for our presentation types. Use this metaclass to define classes that can be automatically presented by w3p")) (defmethod mop:validate-superclass ((class presentation-type-metaclass) (super standard-class)) "Our classes may inherit from ordinary classes." t) (defmethod mop:validate-superclass ((class standard-class) (super presentation-type-metaclass)) "Ordinary classes may NOT inherit from our classes." nil) (defclass presentation-type-slot-definition (mop:standard-slot-definition) ((presentation-type :initarg :presentation-type :accessor slot-definition-presentation-type :documentation "W3P Presentation type specifier for this slot. If unbound or NIL the slot will not be presented") ; TODO :inihibit-p ? (default :initarg :default :accessor slot-definition-presentation-default :documentation "Default value for presenting this slot") (prompt :initarg :prompt :accessor slot-definition-presentation-prompt :documentation "Prompt for presenting this slot."))) (defclass presentation-type-direct-slot-definition (mop:standard-direct-slot-definition presentation-type-slot-definition) ()) (defclass presentation-type-effective-slot-definition (mop:standard-effective-slot-definition presentation-type-slot-definition) ()) (defmethod mop:direct-slot-definition-class ((class presentation-type-metaclass) &rest initargs) (declare (ignore initargs)) (find-class 'presentation-type-direct-slot-definition)) (defmethod mop:effective-slot-definition-class ((class presentation-type-metaclass) &rest initargs) (declare (ignore initargs)) (find-class 'presentation-type-effective-slot-definition)) ;;; ;;; (defclass presentation-type-object () () (:documentation "Superclass of all presentation-type classes. Automatically inherited if using presentation-type-metaclass") (:metaclass presentation-type-metaclass)) (defmethod shared-initialize :around ((class presentation-type-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from presentation-type-object." (let* ((presentation-type-object (find-class 'presentation-type-object)) (needs-work (loop for superclass in direct-superclasses never (eq (class-of superclass) class)))) (if (and (not (eq class presentation-type-object)) needs-work) (apply #'call-next-method class slot-names :direct-superclasses (cons presentation-type-object direct-superclasses) args) (call-next-method)))) ;;; ;;; (defmacro DEFINE-PRESENTATION-METHODS-FOR-PRESENTATION-TYPE (PRESENTATION-TYPE) "Define default presentation methods to present and accept-present-default for the CLOS class PRESENTATION-TYPE." `(progn (w3p:define-presentation-type ,presentation-type () :inherit-from t #+nil ;; hurts during first time compiling-toplevel. :description #+nil (or (documentation (find-class ',PRESENTATION-TYPE) 'class) (format nil "Presentation type for ~A objects" ',PRESENTATION-TYPE))) (eval-when (:load-toplevel) (setf (w3p::presentation-type-description (w3p::find-presentation-type ',presentation-type)) (or (documentation (find-class ',PRESENTATION-TYPE) 'class) (format nil "Presentation type for ~A objects" ',PRESENTATION-TYPE)))) (w3p:define-presentation-method w3p:present (,PRESENTATION-TYPE (type ,PRESENTATION-TYPE) stream (view w3p:html-view) &key) (html:new-paragraph :stream stream) (let ((slotds (mop:class-direct-slots (find-class ',PRESENTATION-TYPE)))) (html:with-table (:stream stream :cell-spacing 4 :cell-padding 2) (loop for slotd in slotds for doc = (documentation slotd 'slot) for type-spec = (if (slot-boundp slotd 'presentation-type) (slot-value slotd 'presentation-type)) for name = (mop:slot-definition-name slotd) for prompt = (if (slot-boundp slotd 'prompt) (slot-value slotd 'prompt) doc) for val = (if (slot-boundp type name) (slot-value type name) (progn (setq type-spec 'w3p:string) "[Unbound]")) do (html:with-table-row (:stream stream) (html:with-table-cell (:stream stream) (html:with-rendition (:bold :stream stream) (write-string (symbol-name name) stream)) (write-string ": " stream)) (html:with-table-cell (:stream stream) (if type-spec (w3p:present val type-spec :stream stream :view view :prompt prompt :acceptably t :prompt-mode :raw) (html:with-rendition (:italic :stream stream) (format stream "~A" val))))))))) (w3p:define-presentation-method w3p:accept-present-default ((type ,PRESENTATION-TYPE) stream (view w3p:html-view) default default-supplied-p present-p query-identifier &key prompt prompt-mode display-default insert-default active-p) (declare (ignore present-p) (optimize debug)) (html:new-paragraph :stream stream) (w3p:with-presentation-type-parameters (,PRESENTATION-TYPE type) (w3p:with-standard-html-prompt (type :stream stream :default default :default-supplied-p default-supplied-p :prompt prompt :prompt-mode prompt-mode :display-default display-default) (cond (active-p (let ((slotds (mop:class-direct-slots (find-class ',PRESENTATION-TYPE)))) (html:with-table (:stream stream :cell-spacing 4 :cell-padding 2) (loop for slotd in slotds for doc = (documentation slotd 'slot) for name = (mop:slot-definition-name slotd) for query-id = (concatenate 'string query-identifier "-" (symbol-name name)) for default2 = (if default (if (slot-boundp default name) (slot-value default name)) (if (slot-boundp slotd 'default) (slot-value slotd 'default))) for presentation-type = (if (slot-boundp slotd 'presentation-type) (slot-value slotd 'presentation-type)) for prompt = (if (slot-boundp slotd 'prompt) (slot-value slotd 'prompt) ; XXX (or doc "")) when presentation-type ;; ignore others for now do (html:with-table-row (:stream stream) (html:with-table-cell (:stream stream) (html:with-rendition (:bold :stream stream) (write-string (symbol-name name) stream)) (write-string ": " stream)) (html:with-table-cell (:stream stream) (apply 'w3p:accept presentation-type (nconc (list :stream stream :view view :present-p present-p :prompt prompt :prompt-mode prompt-mode :query-identifier query-id :insert-default insert-default :active-p active-p) (if default2 (list :default default2)))) (html:horizontal-line :stream stream))))))) ;; note that its upto our caller to add submit ;; buttons and put us in a fillout form. (t (when default-supplied-p (w3p:present default type :stream stream :view view :acceptably t) default)))))))) ;; utility (defun write-submit-and-reset-buttons (stream) (html:with-table (:stream stream :cell-spacing 4 :cell-padding 2) (html:with-table-row (:stream stream) (html:with-table-cell (:stream stream :horizontal-alignment :center :column-span 2) (html:accept-input 'html:submit-button "Submit" :stream stream) (write-char #\Tab stream) (html:accept-input 'html:reset-button "Reset" :stream stream))))) ;; utility (defun get-presentation-type-identifier-from-spec (presentation-type) (etypecase presentation-type ;kludge (symbol presentation-type) (cons (check-type (car presentation-type) symbol) (car presentation-type)))) ;; accept from query alist (defun ACCEPT-PRESENTATION-TYPE-OBJECT-FROM-QUERY-ALIST (type url query-identifier query-alist) "Parse QUERY-ALIST from CL-HTTP form URL to construct a CLOS presentation-type object of class TYPE. QUERY-IDENTIFIER should match the value used in creating accept-present-default." (assert (subtypep type 'presentation-type-object)) (loop with object = (make-instance type) and unboundp = (gensym) for slotd in (mop:class-direct-slots (find-class type)) for name = (mop:slot-definition-name slotd) for query-NAME = (concatenate 'string query-identifier "-" (symbol-name name)) for query-id = (intern query-name http:*keyword-package*) for raw-value = (second (assoc query-id query-alist :test #'eq)) for presentation-type-spec = (if (slot-boundp slotd 'presentation-type) (slot-value slotd 'presentation-type)) when presentation-type-spec do (let ((value unboundp)) (warn "processing ~S raw-value=~S" presentation-type-spec raw-value) (cond (raw-value (unless (http:null-string-p raw-value) ;; XXX: If we get an empty string silently treat ;; it as Unbound. TODO maybe add a slot option ;; to request null-strings explicitly. (handler-case (setq value (w3p:accept-from-string presentation-type-spec raw-value)) (w3p:input-not-of-required-type () (report-invalid-input url query-id presentation-type-spec raw-value))))) ;; If we didn't get a raw value maybe its a presentation type object ((subtypep (get-presentation-type-identifier-from-spec presentation-type-spec) 'presentation-type-object) ;; call recursively (handler-case (setq value (ACCEPT-PRESENTATION-TYPE-OBJECT-FROM-QUERY-ALIST presentation-type-spec url query-NAME query-alist)) (w3p:input-not-of-required-type () (report-invalid-input url query-id presentation-type-spec raw-value)))) (t (report-invalid-input url query-id presentation-type-spec raw-value))) (unless (eq value unboundp) (setf (slot-value object name) value))) finally (return object))) ;;; ;;; ;;; (defparameter *sslca-directory* #p"home:/sslca/") ; XXX Single user only! ;;; ;;; (defparameter set-directory-form-url #u"/sslca/set-directory.html" "Set the directory for our SSL CA.") (pushnew 'set-directory-form-url index-section-urls) (defun write-set-directory-form (url stream &optional (*sslca-directory* *sslca-directory*)) (html:with-table (:stream stream) (html:with-table-row (:stream stream) (html:with-table-cell (:stream stream) (html:with-table (:stream stream) (html:with-table-row (:stream stream) (html:with-table-cell (:stream stream) (html:with-rendition (:bold :stream stream) (write-string "SSL CA Directory: " stream))) (html:with-table-cell (:stream stream) (html:with-rendition (:teletype :stream stream) (format stream "~A" (truename *sslca-directory*)))))))) (html:with-table-row (:stream stream) (html:with-table-cell (:stream stream) (html:with-fillout-form (:post url :stream stream) (w3p:accept 'w3p:pathname :stream stream :view w3p:+html-view+ :present-p t :default *sslca-directory* :prompt nil :prompt-mode :raw :query-identifier "SSLCADIRECTORY" :insert-default t :active-p t) (html:accept-input 'html:submit-button "Submit" :stream stream)))))) (defmethod write-form-for-set-directory ((url url:http-form) stream) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (write-set-directory-form url stream))) (defmethod respond-to-set-directory ((url url:http-form) stream query-alist) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (let ((query-id (intern "SSLCADIRECTORY" http:*keyword-package*))) (let (value) (let ((raw-value (second (assoc query-id query-alist :test #'eq)))) (cond (raw-value (handler-case (setq value (w3p:accept-from-string 'w3p:pathname raw-value)) (w3p:input-not-of-required-type () (report-invalid-input url query-id 'w3p:pathname raw-value)))) (t (report-invalid-input url query-id 'w3p:pathname raw-value)))) (when value (html:with-rendition (:teletype :stream stream) (let ((truename (ignore-errors (truename value)))) (if (null truename) ; TODO report more error? (report-invalid-input url query-id 'w3p:pathname value) (unless (equal truename (truename *sslca-directory*)) ; small bug (html:with-rendition (:teletype :stream stream) (format stream "SET SSL CA Directory to ~A. (Original value was ~A)" value *sslca-directory*) (setq *sslca-directory* value))))))))) (write-sslca-anchor stream))) ;;; http://localhost:8000/sslca/set-directory.html (http:export-url set-directory-form-url :html-computed-form :form-function #'write-form-for-set-directory :response-function #'respond-to-set-directory :no-cache t :language :en :documentation "" :keywords '(:cl-http :sslca :demo)) ;;; INTERFACE TO INVOKE OPENSSL ;;; ;;; (defun %openssl-run-command (run-command stream) (let (proc) (unwind-protect (setq proc (ext:run-program "openssl" run-command :wait t :pty nil :input nil :output :stream)) (when proc (http:stream-copy-until-eof (ext:process-output proc) stream) (ext:process-close proc))))) (defun openssl-run-command (run-command stream) "Outputs to HTML page" (html:with-rendition (:teletype :stream stream) (format stream "openssl ~{~A~^ ~}~&" run-command)) (html:with-verbatim-text (:stream stream) (%openssl-run-command run-command stream))) ;;; ;;; ;;; PRIVATE KEY MANAGEMENT ;;; (defparameter *private-key-filename* "key.pem") (defun private-key-pathname () (merge-pathnames (pathname *private-key-filename*) *sslca-directory* nil)) ;;; ;;; (defparameter generate-private-key-url #u"/sslca/generate-private-key.html" "Generate our private key if not existant.") (pushnew 'generate-private-key-url index-section-urls) (defparameter *rsa-numbits* 512) ; TODO ;; Utility (defmacro with-non-existant-file ((variable pathname &key if-exists-print stream) &body body) "Ensures PATHNAME does not exist and is writeable. If the file exists print IF-EXISTS-PRINT. Otherwise execute BODY forms binding variable to a valid truename of the non-existant file." `(let ((,variable ,pathname)) (cond ((probe-file ,variable) (format ,stream "~A:~@[~S~]" ,variable ,if-exists-print)) (t (setq ,variable (with-open-file (stream ,variable :direction :output) (truename stream))) (delete-file ,variable) ,@body)))) (defmethod generate-private-key ((url url:http-computed-url) stream) (http:with-successful-response (stream :html :content-location url :expires (url:expiration-universal-time url) :cache-control (url:response-cache-control-directives url) :content-language (url:languages url)) (with-non-existant-file (key-path (private-key-pathname) :if-exists-print "Private key file exists. Delete it manually." :stream stream) (openssl-run-command (list "genrsa" "-out" (namestring key-path)) stream)) (write-sslca-anchor stream))) ;;; http://localhost:8000/sslca/generate-private-key.html" (http:export-url generate-private-key-url :computed :response-function #'generate-private-key :no-cache t :language :en :documentation "" :keywords '(:cl-http :sslca :demo)) ;;; ;;; (defparameter private-key-url #u"/sslca/private-key.html" "Print our private key details.") ; XXX (pushnew 'private-key-url index-section-urls) (defun %write-rsa-key-information (file-namestring stream) (openssl-run-command (list "rsa" "-text" "-in" file-namestring "-text") stream)) (defmethod write-key-information ((url url:http-computed-url) stream) (http:with-successful-response (stream :html :content-location url :expires (url:expiration-universal-time url) :cache-control (url:response-cache-control-directives url) :content-language (url:languages url)) (let ((key-path (ignore-errors (truename (private-key-pathname))))) (if key-path (%write-rsa-key-information (namestring key-path) stream) (progn (format stream "No private key ~A.~&" (private-key-pathname)) (html:note-anchor "Generate it." :reference generate-private-key-url :stream stream)))) (write-sslca-anchor stream))) ;;; http://localhost:8000/sslca/private-key.html (http:export-url private-key-url :computed :response-function #'write-key-information :no-cache t :language :en :documentation "" :keywords '(:cl-http :sslca :demo)) ;;; ;;; Our Self Signed Certificate ;;; (defparameter *cacert-filename* "cacert.pem") (defun cacert-pathname () (merge-pathnames (pathname *cacert-filename*) *sslca-directory* nil)) (defparameter generate-cacert-url #u"/sslca/generate-ca-cert.html" "Generate our self signed CA Certificate if not existant.") (pushnew 'generate-cacert-url index-section-urls) ;;; ;;; (defclass subject () ((c :type string :default "GB" :presentation-type (w3p:bounded-string 2) :initarg c :documentation "Country Name (2 letter code)") (st :type string :presentation-type w3p:string :default "Berkshire" :initarg st :documentation "State or Province Name (full name)") (l :type string :presentation-type w3p:string :default "Newbury" :initarg l :documentation "Locality Name (eg, city)") (o :presentation-type w3p:string :type string :default "My Company Ltd" :initarg o :documentation "Organization Name (eg, company)") (cn :presentation-type w3p:string :type string :initarg cn :documentation "Common Name (eg, your name or your server's hostname)") (email :presentation-type w3p:string :initarg email :type string :documentation "Email Address") (ou :presentation-type w3p:string :initarg ou :type string :documentation "Organizational Unit Name (eg, section)")) (:metaclass presentation-type-metaclass)) (DEFINE-PRESENTATION-METHODS-FOR-PRESENTATION-TYPE SUBJECT) (defun get-dn-string (subject) (with-slots (c st l o ou cn email) subject ;; TODO Errorcheck (format nil "/C=~A/ST=~A/L=~A/O=~A/OU=~A/CN=~a/emailAddress=~a" c st l o ou cn email))) (defun parse-dn (string) (flet ((read-item (string &optional (start 0) end) (assert (char= (char string start) #\/)) (let ((pos (position #\= string :start start :end end))) (when pos (let ((pos2 (position #\/ string :start (1+ pos) :end end))) (values (subseq string (1+ start) pos) (subseq string (1+ pos) pos2) pos2)))))) (let ((subject (make-instance 'subject))) (with-slots (c st l o ou cn email) subject (loop for start = 0 then pos2 for (key val pos2) = (multiple-value-list (read-item string start)) do (cond ((string= key "C") (setf c val)) ((string= key "ST") (setf st val)) ((string= key "L") (setf l val)) ((string= key "O") (setf o val)) ((string= key "OU") (setf ou val)) ((string= key "CN") (setf cn val)) ((string= key "emailAddress") (setq email val))) until (null pos2))) subject))) (trace parse-dn get-dn-string) (defun write-generate-cacert-form (url stream) (let ((default (parse-dn "/C=IN/ST=Colaba/L=Mumbai/O=TIFR Mumbai/OU=ECOMLAB/CN=hamming.ecom.tifr.res.in/emailAddress=madhu@hamming.ecom.tifr.res.in"))) ; XXX (html:with-fillout-form (:post url :stream stream) (w3p:accept 'subject :stream stream :view w3p:+html-view+ :present-p t :default default :prompt nil :prompt-mode :normal :query-identifier "SUBJECT" :insert-default t :active-p t) (write-submit-and-reset-buttons stream)))) (defmethod write-form-for-generate-cacert ((url url:http-form) stream) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (if (probe-file (cacert-pathname)) (format stream "~S CACert file exists. Delete it manually." (cacert-pathname)) (write-generate-cacert-form url stream)) (write-sslca-anchor stream))) (defmethod respond-to-generate-cacert ((url url:http-form) stream query-alist) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (with-non-existant-file (cacert-path (cacert-pathname) :if-exists-print "CA Cert file exists. Delete it manually." :stream stream) (let ((subject (ACCEPT-PRESENTATION-TYPE-OBJECT-FROM-QUERY-ALIST 'subject url "SUBJECT" query-alist))) (when subject (openssl-run-command (list "req" "-new" "-x509" "-key" (namestring (truename (private-key-pathname))) "-subj" (get-dn-string subject) "-out" (namestring cacert-path)) stream)))) (write-sslca-anchor stream))) ;; http://localhost:8000/sslca/generate-ca-cert.html (http:export-url generate-cacert-url :html-computed-form :form-function #'write-form-for-generate-cacert :response-function #'respond-to-generate-cacert :no-cache t :language :en :documentation "" :keywords '(:cl-http :sslca :demo)) ;;; ;;; ;;; (defparameter cacert-url #u"/sslca/ca-cert.html" "Print our CA Certificate details.") (pushnew 'cacert-url index-section-urls) (defun %write-x509-cacert-information (file-namestring stream) (openssl-run-command (list "x509" ;; "-CAkey" (private-key-pathname) ;; "-CAcreateserial" "-text" "-in" file-namestring) stream)) (defmethod write-cacert-information ((url url:http-computed-url) stream) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (let ((cacert-path (ignore-errors (truename (cacert-pathname))))) (if cacert-path (%write-x509-cacert-information (namestring cacert-path) stream) (progn (format stream "No cacert ~A.~&" (cacert-pathname)) (html:note-anchor "Generate it." :reference generate-cacert-url :stream stream)))) (write-sslca-anchor stream))) ;;; http://localhost:8000/sslca/ca-cert.html (http:export-url cacert-url :computed :response-function #'write-cacert-information ;; :expiration '(:interval #.(* 60 15)) :no-cache t :language :en :documentation "" :keywords '(:cl-http :sslca :demo)) ;;; ;;; ;;; An INDEX Section (defun write-index-section (stream) (html:horizontal-line :stream stream) (let ((title "INDEX")) (html:with-section-heading (title :stream stream) (loop for url-var in index-section-urls for doc = (or (documentation url-var 'variable) "[]") for val = (symbol-value url-var) do (html:note-anchor doc :reference val :stream stream) (html:break-line :stream stream))))) ;;; ;;; THE WHALE ;;; (defun write-sslca-webpage (url stream) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url::languages url)) (let* (truename (title (format nil "Personal SPKI/OpenSSL CA: ~A on ~A" (if (setq truename (ignore-errors (truename *sslca-directory*))) (car (last (pathname-directory truename))) "[Error Getting SSL CA directory]") ;; The SSL CA instance is named by the directory (www-utils:local-host-domain-name)))) (html:with-html-document (:declare-dtd-version-p t :stream stream) (html:with-document-preamble (:stream stream) (html:declare-base-reference url :stream stream) (html:declare-title title :stream stream)) (html:with-standard-document-body (:stream stream) (html:with-section-heading (title :stream stream) (html:with-rendition (:bold :stream stream) (write-string "Directory" stream)) (html:with-rendition (:teletype :stream stream) (format stream " ~S (~S)" *sslca-directory* truename)) (write-index-section stream))))))) ;;;http://localhost:8000/sslca/begin.html (http:export-url sslca-url :computed :response-function #'write-sslca-webpage :public t :no-cache t ;; :expiration '(:interval #.(* 60 15)) :language :en :documentation "" :keywords '(:cl-http :demo)) ;;; ;;;Try to send binary data over CMUCL's http-stream ;;; (defparameter +favicon-png-data+ #(137 80 78 71 13 10 26 10 0 0 0 13 73 72 68 82 0 0 0 16 0 0 0 16 8 0 0 0 0 58 152 160 189 0 0 0 9 112 72 89 115 0 0 11 18 0 0 11 18 1 210 221 126 252 0 0 0 7 116 73 77 69 7 213 8 14 8 12 50 52 249 84 250 0 0 0 79 73 68 65 84 120 156 133 142 49 14 0 49 8 195 156 138 255 127 57 55 4 218 74 29 142 1 137 96 44 100 4 152 169 66 24 196 164 139 204 38 40 11 50 131 145 160 0 181 193 168 137 187 158 160 226 152 150 192 68 36 220 4 35 141 227 62 104 242 236 161 216 159 111 226 231 143 39 248 0 251 223 19 41 90 234 142 61 0 0 0 0 73 69 78 68 174 66 96 130) #+nil (with-open-file (stream "home:sslca/foo.png" :element-type '(unsigned-byte 8)) (let* ((length (file-length stream)) (array (make-array length :element-type '(unsigned-byte 8) :initial-element 0))) (read-sequence array stream) array))) (defparameter +favicon-last-modified-date+ 3333007165 ; XXX Adjust Unix-epoch? #+nil (get-universal-time)) (defmacro with-binary-stream ((stream) &body body) ; cmucl;server;unix ;; temporarily switch stream-element-type `(LET ((ORIG-ELEMENT-TYPE (WWW-UTILS::HTTP-STREAM-ELEMENT-TYPE ,stream))) (UNWIND-PROTECT (PROGN (WHEN (EQ (WWW-UTILS::HTTP-STREAM-BOUT ,stream) #'LISP::ILL-BOUT) (SETF (WWW-UTILS::HTTP-STREAM-BOUT ,stream) #'LISP::OUTPUT-UNSIGNED-BYTE-FULL-BUFFERED)) NIL (SETF (WWW-UTILS::HTTP-STREAM-ELEMENT-TYPE ,stream) '(UNSIGNED-BYTE 8)) ,@body) (SETF (WWW-UTILS::HTTP-STREAM-ELEMENT-TYPE ,STREAM) ORIG-ELEMENT-TYPE)))) (defmethod write-favicon-binary-data-on-url ((url url:http-computed-url) stream) (check-type stream www-utils::http-stream) (http:with-successful-response (stream :png :cache-control (url:response-cache-control-directives url) :content-location url :bytes (length +favicon-png-data+) :character-set (url:character-set url) :expires (url:expiration-universal-time url) :last-modification +favicon-last-modified-date+ :content-language (url::languages url)) (with-binary-stream (stream) (write-sequence +favicon-png-data+ stream)))) ;;; http://localhost:8000/favicon.ico (unless (http::intern-url ;; XXX dont overwrite. server ;; must be loaded anyway (concatenate 'string (http::local-context) "/favicon.ico") :if-does-not-exist :soft) (http:export-url #u"/favicon.ico" :computed :expiration :never :character-set :iso-8859-1 :response-function #'write-favicon-binary-data-on-url :documentation "" :public t)) ;;; ;;; Directory Listings ;;; (defparameter directory-listing-url #u"/sslca/ls.html" "List contents of SSL CA Directory.") (push 'directory-listing-url index-section-urls) (defun %write-file-details-header (stream) (html:with-table-row (:stream stream) (html:with-table-cell (:header-p t :horizontal-alignment :center :stream stream) (write-string "URL" stream)) (html:with-table-cell (:header-p t :horizontal-alignment :center :stream stream) (write-string "Creation Date" stream)) (html:with-table-cell (:header-p t :horizontal-alignment :left :stream stream) (write-string "Bytes" stream)))) (defun %write-file-details (pathname stream) (let ((file-stream-creation-date (file-write-date pathname)) (file-length-in-bytes (with-open-file (file-stream pathname :element-type '(unsigned-byte 8)) (file-length file-stream))) (url (file-namestring pathname))) (html:with-table-row (:stream stream) (html:with-table-cell (:header-p t :horizontal-alignment :center :stream stream) (write-string URL stream)) (html:with-table-cell (:header-p t :horizontal-alignment :center :stream stream) (http::write-standard-time file-stream-creation-date stream)) (html:with-table-cell (:header-p t :horizontal-alignment :left :stream stream) (format stream "~D" file-length-in-bytes))))) (defun %write-directory-listing (directory-pathname stream) (let ((directory-listing (directory (merge-pathnames (make-pathname :name :wild :type :wild :version :wild) directory-pathname nil) :truenamep nil :follow-links nil :check-for-subdirs nil))) (html:with-table (:cell-spacing 4 :cell-padding 4 :stream stream) (%write-file-details-header stream) (loop for entry in (remove-duplicates directory-listing :test (lambda (a b) (string= (namestring a) (namestring b)))) do (%write-file-details entry stream))) directory-listing)) (defmethod write-directory-listing ((url url:http-computed-url) stream) (http:with-successful-response (stream :html :content-location url :expires (url:expiration-universal-time url) :cache-control (url:response-cache-control-directives url) :content-language (url:languages url)) (%write-directory-listing *sslca-directory* stream) (write-sslca-anchor stream))) ;;; http://localhost:8000/sslca/ls.html (http::export-url directory-listing-url :computed :response-function #'write-directory-listing ;; :expiration '(:interval #.(* 60 15)) :no-cache t ;XXX :language :en :documentation "" :keywords '(:cl-http :sslca :demo)) ;;; ;;; Presentation Type: MEMBER-KEYWORD ;;; (w3p:define-presentation-type MEMBER-KEYWORD (&rest members) :inherit-from t :description "(member-keyword &rest LIST). if LIST is empty, any keyword. NONE is treated specially as nil.") (w3p:define-presentation-method w3p:present (keyword (type member-keyword) stream view &key) (declare (ignore view)) (etypecase keyword (null (write-string "NONE" stream)) (keyword (w3p:with-presentation-type-parameters (member-keyword type) (when members (unless (member keyword members) (error "member-keyword ~a not a member of ~a" keyword members))) (write-string (symbol-name keyword) stream)))) keyword) (w3p:define-presentation-method w3p:accept ((type member-keyword) stream view &key) (let ((string (w3p:read-token stream))) (unless (http:null-string-p string) (let ((keyword (intern string http:*keyword-package*))) (w3p:with-presentation-type-parameters (member-keyword type) (cond ((eql keyword :NONE) nil) (members (unless (member keyword members) (w3p:handle-input-error string type :stream stream :view view) ) keyword) (t keyword))))))) (w3p:define-presentation-method w3p:accept-present-default ((type member-keyword) stream (view w3p:html-view) default default-supplied-p present-p query-identifier &key prompt prompt-mode display-default insert-default active-p) (declare (ignore present-p)) (w3p:with-presentation-type-parameters (member-keyword type) (let ((choices (cons :NONE members))) (declare (dynamic-extent choices)) (w3p:with-standard-html-prompt (type :stream stream :default default :default-supplied-p default-supplied-p :prompt prompt :prompt-mode prompt-mode :display-default display-default) (cond (active-p (html:accept-input 'html:select-choices query-identifier :stream stream :choices choices :sequence-p nil :default (when insert-default default) :size :pull-down-menu)) (t (when default-supplied-p (w3p:present default type :stream stream :view w3p:+textual-view+ :acceptably t) default))))))) ;;; Treat presentation-type objects as Unix options ;;; ;;; (defun getopts (object) ;; from-presentation-type-object "Get options from object as a list suitable for passing to EXT:RUN-COMMAND" (loop with class = (class-of object) for slotd in (mop:class-direct-slots class) for name = (mop:slot-definition-name slotd) for presentation-type-spec = (if (slot-boundp slotd 'presentation-type) (slot-value slotd 'presentation-type)) when (and (slot-boundp object name) presentation-type-spec) nconc (ecase (get-presentation-type-identifier-from-spec presentation-type-spec) (w3p:boolean (when (slot-value object name) (list (concatenate 'string "-" (string-downcase (symbol-name name)))))) (w3p:integer (list (concatenate 'string "-" (string-downcase (symbol-name name))) (format nil "~D" (slot-value object name)))) (subject (list (concatenate 'string "-" (string-downcase (symbol-name name))) (get-dn-string (slot-value object name)))) (w3p:string (list (concatenate 'string "-" (string-downcase (symbol-name name))) (slot-value object name))) (member-keyword (when (slot-value object name) ; kludge (list (concatenate 'string "-" (string-downcase (symbol-name name))) (string-downcase (slot-value object name))))) (w3p:pathname (list (concatenate 'string "-" (string-downcase (symbol-name name))) (namestring (truename (slot-value object name)))))))) ;;; Library Utility ;;; (defun get-subject-from-x509-certificate (&optional (cert-pathname (cacert-pathname))) ; XXX (let* ((raw (with-output-to-string (stream) (%openssl-run-command (list "x509" "-subject" "-in" (namestring (truename cert-pathname)) "-noout") stream))) (rawlen (and raw (length raw)))) (warn "parsed subject line from ~A: ~A" cert-pathname raw) (let* ((key-prefix "subject= ") (len (length key-prefix)) (end (position #\newline raw :end rawlen :from-end t))) (cond ((search key-prefix raw) (parse-dn (subseq raw len end))) ; TODO position-parameters for parse-dn (t (error "no subject in certificate ~A: ~A ~A." cert-pathname key-prefix raw)))))) ;;; Options interface for the `openssl req' command ;;; ;;; (defclass reqopts () ((inform :type keyword :initarg :type :presentation-type (member-keyword :der :pem) :documentation "Input format DER or PEM. This specifies the input format. The DER option uses an ASN1 DER encoded form compatible with the PKCS#10. The PEM form is the default format: it consists of the DER format base64 encoded with additional header and footer lines.") (outform :initarg :outform :type keyword :presentation-type (member-keyword :der :pem) :documentation "Output format DER or PEM. This specifies the output format, the options have the same meaning as the inform option.") (in :initarg :in :type pathname :presentation-type w3p:pathname :documentation "Input file. This specifies the input filename to read a request from or stan- dard input if this option is not specified. A request is only read if the creation options (-new and -newkey) are not specified.") (out :initarg :out :type pathname :presentation-type w3p:pathname :documentation "Output File. This specifies the output filename to write to or standard output by default.") (text :initarg :text :type boolean :presentation-type w3p:boolean :documentation "Text form of request.") (pubkey :initarg :pubkey :presentation-type w3p:boolean :type boolean :documentation "Output public key.") (noout :initarg :noout :type boolean :presentation-type w3p:boolean :documentation "Do not output REQ.") (verify :initarg :verify :type boolean :presentation-type w3p:boolean :documentation "Verifies the signature on the REQuest.") (modulus :initarg :modulus :type boolean :presentation-type w3p:boolean :documentation "RSA modulus. This option prints out the value of the modulus of the public key contained in the request.") (nodes :initarg :nodes :type boolean :presentation-type w3p:boolean :documentation "Don't encrypt the output key. This option prints out the value of the modulus of the public key contained in the request.") (subject :initarg :subject :type boolean :presentation-type w3p:boolean :documentation "Output the request's subject.") (passin :initarg :passin :type string :presentation-type w3p:string :documentation "Private key password source. The input file password source. For more information about the for- mat of arg see the PASS PHRASE ARGUMENTS section in openssl(1).") (key :initarg :key :type pathname :presentation-type w3p:pathname :documentation "Use the private key contained in file.") (keyform :initarg :keyform :type keyword :presentation-type (member-keyword :der :pem) :documentation "Key file format PEM DER. The format of the private key file specified in the -key argument. PEM is the default.") (keyout :initarg :keyout :type pathname :presentation-type w3p:pathname :documentation "File to send the key to. This gives the filename to write the newly created private key to. If this option is not specified then the filename present in the configuration file is used.") (newkey :initarg :newkey :type string :documentation "rsa:bits generate a new RSA key of 'bits' in size." :presentation-type w3p:string) (digest :initarg :digest :type keyword :presentation-type (member-keyword :md5 :sha1 :md2 :mdc2 :md4) :documentation "Digest to sign with (md5, sha1, md2, mdc2, md4)") (subj :initarg :subj :presentation-type subject ;;w3p:string ; XXX :type subject :documentation "Set or modify request subject sets subject name for new request or supersedes the subject name when processing a request. The arg must be formatted as /type0=value0/type1=value1/type2=..., characters may be escaped by \ (backslash), no spaces are skipped.") ; TODO (new :initarg :new :type boolean :presentation-type w3p:boolean :documentation "new request. This option generates a new certificate request. It will prompt the user for the relevant field values. The actual fields prompted for and their maximum and minimum sizes are specified in the configura- tion file and any requested extensions. If the -key option is not used it will generate a new RSA private key using information specified in the configuration file.") (batch :initarg :batch :type boolean :presentation-type w3p:boolean :documentation "Do not ask anything during request generation. Non-interactive mode.") (x509 :initarg :x509 :type boolean :presentation-type w3p:boolean :documentation "Output a x509 structure instead of a cert. req. This option outputs a self signed certificate instead of a certifi- cate request. This is typically used to generate a test certificate or a self signed root CA. The extensions added to the certificate (if any) are specified in the configuration file. Unless specified using the set_serial option 0 will be used for the serial number.") (days :initarg :days :type integer :presentation-type w3p:integer :documentation "Number of days a certificate generated by -x509 is valid for. When the -x509 option is being used this specifies the number of days to certify the certificate for. The default is 30 days.") (set_serial :initarg :set_serial :type integer :presentation-type w3p:integer :documentation "set_serial n serial number to use for a certificate generated by -x509. serial number to use when outputting a self signed certificate. This may be specified as a decimal value or a hex value if preceded by 0x. It is possible to use negative serial numbers but this is not recommended.") (newhdr :initarg :newhdr :type boolean :presentation-type w3p:boolean :documentation "Output NEW in the header lines. Adds the word NEW to the PEM file header and footer lines on the outputed request. Some software (Netscape certificate server) and some CAs need this.") (utf8 :initarg :utf8 :type boolean :presentation-type w3p:boolean :documentation "Input characters are UTF8 (default ASCII). This option causes field values to be interpreted as UTF8 strings, by default they are interpreted as ASCII. This means that the field values, whether prompted from a terminal or obtained from a config- uration file, must be valid UTF8 strings.")) (:documentation "Opts for the OpenSSL req comand. Screen scrapped from `req -help' and `man req'.") (:metaclass presentation-type-metaclass)) (DEFINE-PRESENTATION-METHODS-FOR-PRESENTATION-TYPE reqopts) ;;; ;;; Create an X509 Certificate Request that can be signed by some other CA. ;;; (defparameter generate-certificate-request #u"/sslca/generate-certificate-request.html" "Generate an X509 Certificate request object.") (pushnew 'generate-certificate-request index-section-urls) (defmethod write-form-for-generate-certificate-request ((url url:http-form) stream) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (html:with-fillout-form (:post url :stream stream :ENCODING-TYPE '(:MULTIPART :FORM-DATA)) (let ((defaults (make-instance 'reqopts))) (with-slots (key subj) defaults (setf subj (get-subject-from-x509-certificate)) ; default subject is ourselves (setf key (private-key-pathname))) (w3p:accept 'reqopts :stream stream :view w3p:+html-view+ :present-p t :default defaults :prompt nil :prompt-mode :normal :query-identifier "REQOPTS" :insert-default t :active-p t) (write-submit-and-reset-buttons stream))) (write-sslca-anchor stream))) (defmethod respond-to-generate-certificate-request ((url url:http-form) stream query-alist) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (format stream "QUERY-ALIST: ~S" query-alist) (html:break-line :stream stream) (let ((reqopts (ACCEPT-PRESENTATION-TYPE-OBJECT-FROM-QUERY-ALIST 'reqopts url "REQOPTS" query-alist))) (html:with-verbatim-text (:stream stream) (format stream "reqopts=~S~&" reqopts) (w3p:present reqopts 'reqopts :stream stream :view 'w3p:+html-view+) (html:break-line :stream stream) (format stream "command=~S~&" (getopts reqopts)))) (write-sslca-anchor stream))) ;;; http://localhost:8000/sslca/generate-certificate-request.html (http:export-url generate-certificate-request :html-computed-form :form-function #'write-form-for-generate-certificate-request :response-function #'respond-to-generate-certificate-request :no-cache t :language :en :documentation "" :keywords '(:cl-http :sslca :demo)) ;;; TODO ;;; Sign an X509 Certificate request, after uploading the certificate request. ;;; (defparameter sign-certificate-request #u"/sslca/sign-certificate-request.html" "Sign an X509 Certificate request object.") (pushnew 'sign-certificate-request index-section-urls) (defmethod write-form-for-sign-certificate-request ((url url:http-form) stream) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (html:with-fillout-form (:post url :stream stream :ENCODING-TYPE '(:MULTIPART :FORM-DATA)) (html:accept-input 'html:file "REQ" :default "req.pem" :size 40 :stream stream) (html:break-line :stream stream) (html:accept-input 'html:submit-button "Submit" :stream stream)) (write-sslca-anchor stream))) (defmethod respond-to-sign-certificate-request ((url url:http-form) stream query-alist) (http:with-successful-response (stream :html :cache-control (url:response-cache-control-directives url) :content-location url :content-language (url:languages url)) (format stream "~A" (list "req" )) (html:with-verbatim-text (:stream stream) (format stream "~S" query-alist)) (write-sslca-anchor stream))) ;;; http://localhost:8000/sslca/sign-certificate-request.html (http:export-url sign-certificate-request :html-computed-form :form-function #'write-form-for-sign-certificate-request :response-function #'respond-to-sign-certificate-request :no-cache t :language :en :documentation "" :keywords '(:cl-http :sslca :demo)) ;;; ;;; TODO ;;; - URL access control to localhost. ;;; - Session-manage the default directory, prefs. ;;; - Session-manage upload file. ;;; - file size date checkbox ;;; - operation: view sign ;;; - Underline or highlight special rows in presentation. ;;;