/[lisppaste]/lisppaste2/system-server.lisp
ViewVC logotype

Contents of /lisppaste2/system-server.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Feb 13 22:16:25 2009 UTC (5 years, 2 months ago) by lisppaste
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +1 -1 lines
Fix the system-server after changing to pre-wrap instead of tt
1 (in-package :lisppaste)
2
3 (defparameter *memoize-colorize-table* (make-hash-table :test #'equal))
4
5 (defun all-system-names ()
6 (loop for i being each hash-key of asdf::*defined-systems* collect i))
7
8 (defun find-component-from-string (string &key root)
9 (multiple-value-bind (component-name start-of-rest)
10 (split-sequence:split-sequence #\/ string :count 1)
11 (let ((new-root (asdf:find-component root (car component-name))))
12 (if new-root
13 (if (> (length string) start-of-rest)
14 (find-component-from-string (subseq string start-of-rest) :root new-root)
15 new-root)))))
16
17 (defclass main-system-server-handler (handler) ())
18
19 (defclass show-component-handler (handler) ())
20
21 (defmethod handle-request-response ((handler main-system-server-handler) method request)
22 (request-send-headers request :expires 0)
23 (xml-output-to-stream
24 (request-stream request)
25 (lisppaste-wrap-page
26 "Select a System"
27 (<div class="controls">
28 (<ul>
29 (loop for i in (all-system-names)
30 for system = (asdf:find-system i)
31 collect (<li>
32 (<a href=?(urlstring (merge-url *show-component-url*
33 i))>
34 i)
35 " - "
36 (or (ignore-errors (asdf:system-description system))
37 (ignore-errors (asdf:system-long-description system))
38 "No Description"))))))))
39
40 (defun memoize-colorize-file (component type)
41 (let ((ent (list (asdf:component-pathname component)
42 colorize:*version-token*
43 (file-write-date (asdf:component-pathname component)))))
44 (multiple-value-bind (val found) (gethash ent *memoize-colorize-table*)
45 (if found
46 val
47 (setf (gethash ent *memoize-colorize-table*)
48 (with-output-to-string (s)
49 (colorize:colorize-file-to-stream type
50 (asdf:component-pathname component) s :wrap nil :css-background "paste")))))))
51
52 (defun component-sorter (c1 c2)
53 (if (typep c1 'asdf:module)
54 (if (typep c2 'asdf:module)
55 (string< (asdf:component-name c1) (asdf:component-name c2))
56 t)
57 (if (typep c2 'asdf:module)
58 nil
59 (string< (asdf:component-name c1) (asdf:component-name c2)))))
60
61 (defun module-div (component url)
62 (<div>
63 (when (typep component 'asdf:system)
64 (<div class="info-text">
65 (<span class="small-header">
66 (format nil "About system \"~A\""
67 (asdf:component-name component)))
68 <p/>
69 (<table>
70 (<tr>
71 (<td> (<b> "Name"))
72 (<td> (asdf:component-name component)))
73 (<tr>
74 (<td> (<b> "Version"))
75 (<td> (or (ignore-errors (asdf:component-version component)) "None")))
76 (<tr>
77 (<td> (<b> "Author"))
78 (<td> (or (ignore-errors (asdf:system-author component)) "None")))
79 (<tr>
80 (<td> (<b> "License"))
81 (<td> (or (ignore-errors (asdf:system-license component)) "None")))
82 (<tr>
83 (<td> (<b> "Description"))
84 (<td> (or (ignore-errors (asdf:system-description component)) "None")))
85 (<tr>
86 (<td> (<b> "Long Description"))
87 (<td> (or (ignore-errors (asdf:system-long-description component)) "None"))))))
88 (<div class="controls">
89 (<span class="small-header"> "Select a component:")
90 (<ul>
91 (loop for i in (sort (copy-list (asdf:module-components component)) #'component-sorter)
92 for link = (<a href=?(concatenate 'string
93 url
94 "/"
95 (asdf:component-name i))>
96 (asdf:component-name i))
97 if (typep i 'asdf:module) collect (<li> (<b> link))
98 else collect (<li> link))))))
99
100 (defun file-div (component type)
101 (<table width="100%" class="paste-area">
102 (<tr>
103 (<td bgcolor="#F4F4F4">
104 (if (eql type :none)
105 (<pre>
106 (with-output-to-string (s)
107 (with-open-file (f (asdf:component-pathname component) :direction :input)
108 (loop for line = (read-line f nil nil)
109 while line
110 do (progn (write-string line s)
111 (terpri s))))))
112 (<pre class="paste-area">
113 (make-unescaped-string
114 (memoize-colorize-file component type))))))))
115
116 (defmethod handle-request-response ((handler show-component-handler) method request)
117 (let ((component (find-component-from-string (request-unhandled-part request))))
118 (and component
119 (progn
120 (request-send-headers request :expires 0)
121 (xml-output-to-stream
122 (request-stream request)
123 (lisppaste-wrap-page
124 (format nil "Component ~A" (asdf:component-name component))
125 (<div>
126 (<div class="controls">
127 "You are here: "
128 (<a href=?(urlstring *main-system-server-url*)>
129 "All Systems")
130 (loop for i in (reverse (maplist #'reverse (nreverse (split-sequence:split-sequence #\/ (request-unhandled-part request)))))
131 collect " / "
132 collect (<a href=?(urlstring (merge-url *show-component-url*
133 (format nil "~{~A~^/~}"
134 i)))>
135 (car (last i)))))
136 <p/>
137 (typecase component
138 (asdf:module (module-div component (urlstring (request-url request))))
139 (asdf:cl-source-file (file-div component :common-lisp-file))
140 (asdf:static-file
141 (file-div component (if (equalp (pathname-type (asdf:component-pathname component)) "lisp")
142 :common-lisp-file
143 :none)))
144 (t (<div class="paste-area">
145 "I'm afraid I don't quite know what to do with this file."))))))))))
146
147 (when *serve-source*
148 (install-handler
149 (http-listener-handler *paste-listener*)
150 (make-instance 'main-system-server-handler)
151 (urlstring *main-system-server-url*) t)
152
153 (install-handler
154 (http-listener-handler *paste-listener*)
155 (make-instance 'show-component-handler)
156 (urlstring *show-component-url*) nil))

  ViewVC Help
Powered by ViewVC 1.1.5