(defpackage :ql-info-dump1 (:use :cl :cl-ppcre :hunchentoot :cl-who)) (in-package :ql-info-dump1) (ql:quickload "hunchentoot") (ql:quickload "cl-ppcre") (ql:quickload "cl-who") (defparameter *web-server* NIL) (defparameter *server-port* 8080) (defvar *utf-8* (flex:make-external-format :utf-8 :eol-style :lf)) (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) (defparameter hunchentoot:reply-external-format (flex:make-external-format :utf-8 :eol-style :lf)) (setf hunchentoot:*default-content-type* "text/html; charset=utf-8") (setf *web-server* (make-instance 'hunchentoot:easy-acceptor :port *server-port*)) (hunchentoot:start *web-server*) (push (hunchentoot:create-folder-dispatcher-and-handler "/css/" "/home/sabra/quicklisp/local-projects/ql-info-dump/css/") hunchentoot:*dispatch-table*) (push (hunchentoot:create-folder-dispatcher-and-handler "/xhtml/" "/home/sabra/quicklisp/local-projects/ql-info-dump/docs/xhtml/") hunchentoot:*dispatch-table*) ;; ------------------- Helper Functions ---------------------------- (defun list-quicklisp-package-names () "lists the package names of the quicklisp libraries" (let ((package-list (ql:system-list)) (package-list-strings ())) (dolist (x package-list) (let ((string-x (cl-ppcre:regex-replace-all "#<QL-DIST:SYSTEM |>" (write-to-string x) ""))) (push (first (cl-ppcre:split " / " string-x)) package-list-strings))) (sort package-list-strings #'string<))) (defun list-current-systems () "Just return a list of all the current systems." (let ((system-list ())) (flet ((push-pkg-to-system-list (pkg) (push (asdf:component-name pkg) system-list))) (asdf:map-systems #'push-pkg-to-system-list)) (sort system-list #'string<))) (defun deal-with-plus (string) "Take a string and replace any spaces with a plus sign." (cl-ppcre:regex-replace-all " " string "+")) (defun get-external-functions (name) "Returns a list of the external function names for the named package. Package is a string. It drops the references to the package name." (let* ((package-name (if (stringp name) (read-from-string name) name)) (package (if (symbolp package-name) (find-package package-name)))) (when (packagep package) (let ((lst ())) (do-external-symbols (s package) (when (sb-introspect:function-type s) (push (write-to-string s) lst))) (sort lst #'string<))))) (defun get-external-non-functions (name) "Returns a list of the external function names for the named package. Package is a string. It drops the references to the package name." (let* ((package-name (if (stringp name) (read-from-string name) name)) (package (if (symbolp package-name) (find-package package-name)))) (when (packagep package) (let ((lst ())) (do-external-symbols (s package) (unless (sb-introspect:function-type s) (push (write-to-string s) lst))) (sort lst #'string<))))) (defun pkg-file-location (file-name pkg-name) "Given a file name string, returns the full directory location if the file exists or nil" (let ((package-name-symbol (read-from-string pkg-name))) (when (ignore-errors (asdf:find-system package-name-symbol)) (let ((file-exists (cl-fad:file-exists-p (concatenate 'string (namestring (asdf:system-source-directory (asdf:find-system package-name-symbol))) file-name)))) (when file-exists (namestring file-exists)))))) (defun documented-functions (function-list) "Takes a list of function names and returns 2 values, the number of functions with a documenation string and the number of functions without a documentation string" (let ((documented 0) (undocumented 0) (total (length function-list))) (loop for x in function-list do (let ((function-name (read-from-string x))) (when (symbolp function-name) (if (documentation function-name 'function) (incf documented) (incf undocumented))))) (values total documented undocumented))) ;; ------------------- Page Section Areas ---------------------------- (defun banner () "Just a banner" (cl-who:with-html-output-to-string (*standard-output* nil :indent t) (cl-who:htm (:h1 "QuickLisp Info Dump")))) (defun navigation () "Just a nav section" (cl-who:with-html-output-to-string (*standard-output* nil :indent t) (cl-who:htm (:h3 "Loaded Packages") (loop for x in (list-current-systems) do (cl-who:htm (:a :href (concatenate 'string "display-package?name=" x) (cl-who:str x)) (:br)))))) (defun extra-stuff () "Just some extra stuff" (cl-who:with-html-output-to-string (*standard-output* nil :indent t) (cl-who:htm (:h3 "Extras") (:a :href "list-quicklisp-libraries" (cl-who:str"List QuickLisp Libraries")) (:br) (:a :href "compare-packages" (cl-who:str"Compare 2 Loaded Packages")) (:br) (:a :href "docs/xhtml/begin-building-webapp.xhtml" (cl-who:str"How to Build this Webapp"))))) (defun footer-area () "Just some footer stuff" (cl-who:with-html-output-to-string (*standard-output* nil :indent t) (cl-who:htm (:table (:tr (:td (:a :href "http://www.quicklisp.org" (cl-who:str"Quicklisp"))) (:td (:a :href "http://common-lisp.net/" (cl-who:str"Common-Lisp.net"))) (:td (:a :href "http://planet.lisp.org/" (cl-who:str"Planet Lisp"))) (:td (:a :href "http://planet.cliki.net/" (cl-who:str"Planet Cliki"))) (:td (:a :href "http://planet.sbcl.org/" (cl-who:str"Planet SBCL"))) (:td (:a :href "http://cl-user.net/" (cl-who:str"CL Directory"))) (:td (:a :href "http://www.lisp.org/alu/home" (cl-who:str"ALU"))) (:td (:a :href "http://www.lispworks.com/documentation/HyperSpec/Front/" (cl-who:str"Lispworks HyperSpec")))))))) (defun flatten (orig-list) "Takes a nested list and returns a single list with all the previously nested elements." (if (eql orig-list nil) nil (let ((elem (car orig-list)) (resto-list (cdr orig-list))) (if (listp elem) (append (flatten elem) (flatten resto-list)) (append (cons elem nil) (flatten resto-list)))))) (defun find-asdf-system-file (package-string) "Returns a pathname of the asd file for this package." (ql-dist:find-asdf-system-file package-string)) (defun direct-dependencies (component) (cdadr (asdf:component-depends-on 'asdf:load-op (asdf:find-component nil component)))) (defun normalize-system-id (id) (intern (symbol-name id) "KEYWORD")) (defun ensure-list (lst) "From Alexandria. If the parameter is a list, it is returned. Otherwise it turns the parameter into a list and returns that." (if (listp lst) lst (list lst))) (defun %effective-dependencies (components) "Helper function from http://blog.viridian-project.de/2008/07/13/collecting-asdf-system-dependencies/." (when components (remove-duplicates (append components (%effective-dependencies (mapcar #'normalize-system-id (remove-if #'null (flatten (mapcar #'direct-dependencies components)))))) :test #'eq))) (defun effective-dependencies (components) "Find all dependencies needed for the list of COMPONENTS (which may be an atom, too). From http://blog.viridian-project.de/ 2008/07/13/collecting-asdf-system-dependencies/" (let ((components (ensure-list components))) (set-difference (%effective-dependencies components) components :key #'normalize-system-id))) (defun gridify1 (x base-parameter &optional (col 5)) "Given a list of strings, put them in html tbody rows (returned as a string) with |col| columns. Obviously this requires that the calling function has provided the table and thead information." (let* ((length (length x)) (cell-mod (mod length col)) (extra-cells (if (= cell-mod 0) 0 (- col cell-mod)))) (cl-who:with-html-output-to-string (var nil) (cl-who:htm (:tbody (loop for xp on x by (lambda (p) (nthcdr col p)) do (cl-who:htm (:tr (loop for i upto (1- col) for package-name in xp do (cl-who:htm (:td (:a :href (format nil "~a~a" base-parameter (string-downcase package-name)) (cl-who:str (string-downcase package-name))))))))) (dotimes (i extra-cells) (cl-who:htm (:td)))))))) (defmacro defpage-easy-d (name title uri parameter-list docs &body body) "Generates the html page and includes a page template" `(hunchentoot:define-easy-handler (,name :uri ,uri :default-request-type :both) ,parameter-list ,docs (page-template ,title ,@body))) (defmacro page-template (title &body body) "Generates the basic html page template with css" `(cl-who:with-html-output-to-string (*standard-output* nil :prologue t :indent t) (:html (:head (:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8") (:title (cl-who:str (format nil " ~a" ,title))) (:link :rel "stylesheet" :type "text/css" :href "/css/base.css" :media "screen")) (:body (:div :id "container" (:div :id "header" (cl-who:str (banner))) (:div (:div :id "content" (cl-who:str ,@body)) (:div :id "navigation" (cl-who:str (navigation))) (:div :id "extra" (cl-who:str (extra-stuff))) (:div :id "footer" (cl-who:str (footer-area))))))))) (defmacro page-template-1 (title &body body) "Generates the basic html page template with css with no navigation or extras section." `(cl-who:with-html-output-to-string (*standard-output* nil :prologue t :indent t) (:html (:head (:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8") (:title (cl-who:str (format nil " ~a" ,title))) (:link :rel "stylesheet" :type "text/css" :href "/css/base.css" :media "screen")) (:body (:div :id "container" (:div :id "header" (cl-who:str (banner))) (:div (:div :id "content1" (cl-who:str ,@body)) (:div :id "footer" (cl-who:str (footer-area))))))))) (defmacro defpage-easy-d-1 (name title uri parameter-list docs &body body) "Generates the html page and includes a page template with no navigation or extras section." `(hunchentoot:define-easy-handler (,name :uri ,uri :default-request-type :both) ,parameter-list ,docs (page-template-1 ,title ,@body))) (defpage-easy-d list-quicklisp-libraries "list-quicklisp-libraries" "/list-quicklisp-libraries" () "Lists the quicklisp libraries." (cl-who:with-html-output-to-string (*standard-output*) (cl-who:htm (:h1 "Available QuickLisp Libraries")) (loop for x in (nreverse (set-difference (list-quicklisp-package-names) (list-current-systems) :test 'equal)) do (cl-who:htm (:a :href (concatenate 'string "load-library?name=" x) (cl-who:str x)) (:br))))) (defpage-easy-d home-page "QLID" "/" () "Handles base page." (cl-who:with-html-output-to-string (*standard-output*) (cl-who:htm (:h1 "Yes, we have bananas.")))) (defmacro defsnippet-with-docs (name args docs &body body) "A defsnippet-with-docs is a defsnippet with a documentation string." `(defun ,name ,args ,docs (cl-who:with-html-output (*standard-output* nil :prologue nil :indent t) ,@body))) (defsnippet-with-docs package-overview (system-name named-system) "Returns html of functions which call the function-name string" (let ((function-list (get-external-functions system-name))) (multiple-value-bind (total-functions documented-functions undocumented-functions) (documented-functions function-list) (cl-who:htm (:div (:table (:tr (:td (:a :href (concatenate 'string "http://www.cliki.net/admin/search?words=" system-name) (cl-who:str "Cliki Search"))) (:td) (:td (:a :href (concatenate 'string "http://www.lispdoc.com/?search=Basic+search&q=" system-name) (cl-who:str "Lispdoc.com Search")))) (:tr (:th "Author") (:td (cl-who:str (ignore-errors (asdf:system-author named-system)))) (:th "License") (:td (cl-who:str (ignore-errors (asdf:system-license named-system))))) (:tr (loop for x in '("LICENSE" "COPYING" "README" "CHANGES" "CHANGELOG" "AUTHORS" "INSTALL" ) do (if (pkg-file-location x system-name) (cl-who:htm (:td (:a :href (concatenate 'string "file:" (pkg-file-location x system-name)) (cl-who:str x)))))) (when (asdf:system-source-file named-system) (cl-who:htm (:td (:a :href (concatenate 'string "file:" (namestring (asdf:system-source-file named-system))) (cl-who:str (concatenate 'string system-name ".asd"))))))) (:tr (:th "Exported Functions") (:td (cl-who:str (write-to-string total-functions))) (:th "Documented ") (:td (cl-who:str (write-to-string documented-functions))) (:th "Undocumented") (:td (cl-who:str (write-to-string undocumented-functions)))))))))) (defpage-easy-d display-package "display-package" "/display-package" ((name :parameter-type 'string)) "Handles package display requests." (let* ((system-name (deal-with-plus name)) (named-system (ignore-errors (asdf:find-system system-name)))) (when named-system (cl-who:with-html-output-to-string (*standard-output*) (cl-who:htm (:h1 (cl-who:str system-name)) (package-overview system-name named-system) (:div (:h2 "Description") (cl-who:str (ignore-errors (asdf:system-description named-system)))) (:div (:h2 "Depends on") (let* ((dependency-list (effective-dependencies (read-from-string system-name)))) (cl-who:htm (:table (cl-who:str (gridify1 dependency-list "display-package?name=")))))) (:div (:table (:tr (:td (:a :href "#exported-functions" (cl-who:str "Exported Functions"))) (:td (:a :href "#exported-variables" (cl-who:str "Exported Variables")))))) (:div (:h2 (:a :name "exported-functions" (cl-who:str "Exported Functions"))) (loop for x in (get-external-functions system-name) do (cl-who:htm (:a :href (concatenate 'string "display-function?name=" x) (cl-who:str x)) (:br)))) (:div (:h2 (:a :name "exported-variables" (cl-who:str "Exported Variables"))) (loop for x in (get-external-non-functions system-name) do (cl-who:htm (:a :href (concatenate 'string "display-variable?name=" x) (cl-who:str x)) (:br))))))))) (defun write-car-to-string (item) "This is a specialized helper function for sorting calling functions." (write-to-string (car item))) (defsnippet-with-docs calling-functions (function-name) "Returns html of functions which call the function-name string" (:h3 "Functions that call this function") (let ((caller-list ())) (loop for x in (sort (sb-introspect:who-calls (read-from-string function-name)) #'string< :key #'write-car-to-string) do (unless (member (car x) caller-list) (push (car x) caller-list) (let ((caller-pathname (ignore-errors (namestring (sb-introspect:definition-source-pathname (cdr x)))))) (if caller-pathname (cl-who:htm (:a :href (concatenate 'string "file:" caller-pathname) (cl-who:str (car x))) (:br)))))))) (defpage-easy-d display-function "display-function" "/display-function" ((name :parameter-type 'string)) "Handles function display requests." (if (ignore-errors (fdefinition (read-from-string name))) (let* ((package-name (first (cl-ppcre:split ":" name))) (file-pathname (ignore-errors (namestring (sb-introspect:definition-source-pathname (sb-introspect:find-definition-source (fdefinition (read-from-string name)))))))) (cl-who:with-html-output-to-string (*standard-output*) (cl-who:htm (:h2 "Package: " (:a :href (concatenate 'string "display-package?name=" package-name) (cl-who:str package-name))) (:h2 (cl-who:str name)) (:h3 "Documentation String") (cl-who:str (documentation (read-from-string name) 'function)) (:br) (:h3 "Source File") (if file-pathname (cl-who:htm (:a :href (concatenate 'string "file:" file-pathname) (cl-who:str name))) (cl-who:htm (cl-who:str "No file-pathname found!"))) (:h3 "Functions that call this function") (calling-functions name)))) (cl-who:with-html-output-to-string (*standard-output*) (cl-who:htm (:h2 (cl-who:str (concatenate 'string "Unknown function: " name))))))) (defpage-easy-d display-variable "display-variable" "/display-variable" ((name :parameter-type 'string)) "Handles function display requests." (if name (let* ((package-name (first (cl-ppcre:split ":" name))) (file-pathname (ignore-errors (namestring (sb-introspect:definition-source-pathname (sb-introspect:find-definition-source (fdefinition (read-from-string name)))))))) (cl-who:with-html-output-to-string (*standard-output*) (cl-who:htm (:h2 "Package: " (:a :href (concatenate 'string "display-package?name=" package-name) (cl-who:str package-name))) (:h2 (cl-who:str name)) (:h3 "Documentation String") (cl-who:str (if (documentation (read-from-string name) 'variable) (documentation (read-from-string name) 'variable) (if (documentation (read-from-string name) 'function) (documentation (read-from-string name) 'function) "No Documentation Available"))) (:br) (:h3 "Source File") (if file-pathname (cl-who:htm (:a :href (concatenate 'string "file:" file-pathname) (cl-who:str name))) (cl-who:htm (cl-who:str "No file-pathname found!"))) (:h3 "Functions that call this Macro or Variable") (calling-functions name)))) (cl-who:with-html-output-to-string (*standard-output*) (cl-who:htm (:h2 (cl-who:str (concatenate 'string "Unknown Variable or Macro: " name))))))) (defpage-easy-d load-library "Load Library" "/load-library" ((name :parameter-type 'string)) "Takes a name parameter from from hunchentoot, tries to load that library name, then redirects, back to the home page. Quickload will print a successful result of the attempting loading to the main page. Any errors will be triggered in the REPL." (when (ql:quickload name) (hunchentoot:redirect "/"))) (defpage-easy-d-1 compare-packages "Compare Packages" "/compare-packages" ((pkg1 :parameter-type 'string)(pkg2 :parameter-type 'string)) "Generate a form to choose which packages to compare" (cl-who:with-html-output-to-string (*standard-output*) (cl-who:htm (:div (:form :method :get :action "compare-packages" (:select :name "pkg1" (loop for name in (list-current-systems) do (cl-who:htm (:option :value name (cl-who:str name))))) (:select :name "pkg2" (loop for name in (list-current-systems) do (cl-who:htm (:option :value name (cl-who:str name))))) (:input :type "submit"))) (:div (:div :id "col1" (loop for name in (get-external-functions pkg1) do (cl-who:htm (:a :href (concatenate 'string "display-function?name=" name) (cl-who:str name)) (:br)))) (:div :id "col2" (loop for name in (get-external-functions pkg2) do (cl-who:htm (:a :href (concatenate 'string "display-function?name=" name) (cl-who:str name)) (:br)))))))) |