ql-info-dump1 (Update for easy-acceptors)


(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))))))))












Comments