Changeset 2720

Timestamp:

03/11/08 17:25:41 (10 months ago)

Author:

hans

Message:

Checkpoint QuickHoney? work.

Files:

• trunk/bknr/datastore/src/data/object.lisp (modified) (1 diff)
• trunk/bknr/web/src/packages.lisp (modified) (1 diff)
• trunk/bknr/web/src/rss/rss.lisp (modified) (3 diffs)
• trunk/bknr/web/src/web/handlers.lisp (modified) (4 diffs)
• trunk/bknr/web/src/web/template-handler.lisp (modified) (2 diffs)
• trunk/clean.lisp (modified) (1 diff)
• trunk/projects/quickhoney/src/handlers.lisp (modified) (1 diff)
• trunk/projects/quickhoney/src/image.lisp (modified) (2 diffs)
• trunk/projects/quickhoney/src/webserver.lisp (modified) (1 diff)
• trunk/projects/quickhoney/website/templates/index.xml (modified) (2 diffs)
• trunk/thirdparty/drakma-0.11.4/request.lisp (modified) (3 diffs)

trunk/bknr/datastore/src/data/object.lisp

@@ -639 +639 @@
-
-(deftransaction change-slot-values (object &rest slots-and-values)
+  (warn "CHANGE-SLOT-VALUES is deprecated - use WITH-TRANSACTION and standard accessors!")
-  (when object
-    (loop for (slot value) on slots-and-values by #'cddr

trunk/bknr/web/src/packages.lisp

@@ -256 +256 @@
-           #:website
-           #:website-name
-
+
-           #:website-authorizer
-           #:website-show-page

trunk/bknr/web/src/rss/rss.lisp

@@ -19 +19 @@
-         :index-reader find-rss-channel)
-   (title :update :initform nil)
-link
+path
-   (description :update :initform nil)
-   (last-update :update :initform (get-universal-time))
@@ -81 +81 @@
-      (text (or value (format nil "(channel ~(~A~) not defined)" element))))))
-
+(defmethod rss-channel-link ((channel rss-channel))
+  (format nil "http://~A/~A" (bknr.web:website-host) (rss-channel-path channel)))
+
-(defgeneric rss-channel-xml (channel stream)
-  (:documentation "Generate XML for the current state of RSS channel
@@ -89 +92 @@
-        (attribute "version" "2.0")
-        (attribute* "xmlns" "content" "http://purl.org/rss/1.0/modules/content/")
+        (attribute* "xmlns" "atom" "http://www.w3.org/2005/Atom")
-        (with-element "channel"
-          (render-mandatory-element channel 'title)
-          (render-mandatory-element channel 'link)
-          (render-mandatory-element channel 'description)
+          (with-element "link"
+            (text (rss-channel-link channel)))
+          (with-element* ("atom" "link")
+            (attribute "href" (rss-channel-link channel))
+            (attribute "rel" "self")
+            (attribute "type" "application/rss+xml"))
-        
-          (dolist (item (remove-if-not #'(lambda (item)

trunk/bknr/web/src/web/handlers.lisp

@@ -18 +18 @@
-   (url :initarg :url
-        :accessor website-url)
-   (vhosts :initarg :vhosts
-           :accessor website-vhosts)
-   (authorizer :initarg :authorizer
-               :accessor website-authorizer)
@@ -55 +53 @@
-                     :reader website-template-handler))
-  (:default-initargs :url nil
-    :vhosts :wild
-    :authorizer (make-instance 'bknr-authorizer)
-    :menu nil
@@ -70 +67 @@
-  (:documentation "Class to hold all information on a web server that
-is served within BKNR.  Currently, this is a singleton object, and
-
-
+
-
-(defmethod initialize-instance :after ((website website) &key &allow-other-keys)
@@ -78 +74 @@
-  (setf *website* website)
-  (publish-site *website*))
+
+(defun website-host ()
+  (if (and (boundp 'hunchentoot::*request*)
+           hunchentoot::*request*
+           (hunchentoot:header-in :host))
+      (header-in :host)
+      "localhost"))
-
-(defmethod show-handlers ((website website))

trunk/bknr/web/src/web/template-handler.lisp

@@ -45 +45 @@
-                :reader template-expander-destination)
-   (cached-templates :initform (make-hash-table :test 'equal)
-
+
+
+
+
+
+
-
-(defmethod find-tag-function ((expander template-expander) name ns)
@@ -185 +190 @@
-            (values file (cdr components)))))))
-
+(defun split-path (path)
+  "Split path into its components and return them as list.  Empty components are removed."
+  (remove "" (split "/" path) :test #'equal))
+
-(defmethod find-template-pathname ((expander template-expander) template-name)
-
+
+
+
-    (multiple-value-bind (pathname ret-components)
-        (find-template (template-expander-destination expander) components)

trunk/clean.lisp

@@ -6 +6 @@
-(mapc #'delete-file (directory (compile-file-pathname #P"**/*.lisp")))
-
+

trunk/projects/quickhoney/src/handlers.lisp

@@ -186 +186 @@
-                                                :keywords (cons :upload keywords)
-                                                :initargs (list :client client :spider-keywords spider-keywords))))
+                  (with-http-response ()
+                    (with-http-body ()
+                      (html (:html
+                             (:head
+                              (:title "Upload successful")
+                              ((:script :type "text/javascript" :language "JavaScript")
+                               "function done() { window.opener.do_query(); window.close(); }"))
+                             (:body
+                              (:p "Image " (:princ-safe (store-image-name image)) " with " (:princ-safe (hash-table-count color-table)) " colors uploaded")
+                              (:p ((:img :src (format nil "/image/~D" (store-object-id image))
+                                         :width (round (* ratio width)) :height (round (* ratio height)))))
+                              (:p ((:a :href "javascript:done()") "ok")))))))))))
+        (error (e)
+          (with-http-response ()
+            (with-http-body ()
+              (html (:html
+                     (:head
+                      (:title "Error during upload"))
+                     (:body
+                      (:h2 "Error during upload")
+                      (:p "Error during upload:")
+                      (:p (:princ-safe (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e))))
+                      (:p ((:a :href "javascript:window.close()") "ok"))))))))))))
+
+(defclass upload-news-handler (admin-only-handler page-handler)
+  ())
+
+(defmethod handle ((handler upload-news-handler))
+  (with-query-params (title text)
+    (let ((uploaded-file (request-uploaded-file "image-file")))
+      (handler-case
+          (progn
+            (unless uploaded-file
+              (error "no file uploaded"))
+            (with-image-from-upload* (uploaded-file)
+              (let* ((color-table (make-hash-table :test #'eql))
+                     (width (cl-gd:image-width))
+                     (height (cl-gd:image-height))
+                     (ratio (/ 1 (max (/ width 300) (/ height 200)))))
+                (cl-gd:do-pixels ()
+                  (incf (gethash (cl-gd:raw-pixel) color-table 0)))
+                (when (and (cl-gd:true-color-p)
+                           (<= (hash-table-count color-table) 256))
+                  (cl-gd:true-color-to-palette))
+                (let* ((image (make-store-image :name (pathname-name (upload-original-filename uploaded-file))
+                                                :class-name 'quickhoney-news-item
+                                                :keywords (list :upload :news)
+                                                :initargs (list :title title
+                                                                :text text))))
-                  (with-http-response ()
-                    (with-http-body ()

trunk/projects/quickhoney/src/image.lisp

@@ -62 +62 @@
-  (format nil "~@[~A~]/index#~(~A/~A~)/~A"
-          (unless internal
-
-
-
-
-
-
+
-          (quickhoney-image-category image) (quickhoney-image-subcategory image) (store-image-name image)))
-
@@ -76 +71 @@
-  (delete-object (quickhoney-animation-image-animation image)))
-
+(define-persistent-class quickhoney-news-item (quickhoney-image)
+  ((title :update)
+   (text :update)))
+
+(defmethod quickhoney-image-spider-keywords ((item quickhoney-news-item))
+  (quickhoney-news-item-title item))
+
+(defmethod rss-item-title ((item quickhoney-news-item))
+  (quickhoney-news-item-title item))
+
+(defmethod rss-item-encoded-content ((item quickhoney-news-item))
+  (concatenate 'string
+               (call-next-method)
+               (quickhoney-news-item-text item)))

trunk/projects/quickhoney/src/webserver.lisp

@@ -32 +32 @@
-                                        ("/rss" rss-handler)
-                                        ("/admin" admin-handler)
+                                        ("/upload-news" upload-news-handler)
-                                        ("/" template-handler
-                                         :default-template "frontpage"

trunk/projects/quickhoney/website/templates/index.xml

@@ -254 +254 @@
-   <div id="edit_news_form" class="cms_form">
-    <div class="cms_title">Create news entry</div>
-/news
+
-          enctype="multipart/form-data" target="upload_result" onsubmit="do_upload(this.target);">
-     <p class="cms">
@@ -265 +265 @@
-        <tr>
-         <td>Title:</td>
-subject
+title
-        </tr>
-        <tr>

trunk/thirdparty/drakma-0.11.4/request.lisp

@@ -200 +200 @@
-                              #+:lispworks (read-timeout 20)
-                              #+(and :lispworks (not :lw-does-not-have-write-timeout))
-
+
+
-  "Sends an HTTP request to a web server and returns its reply.  URI
-is where the request is sent to, and it is either a string denoting a
@@ -374 +375 @@
-if an existing stream is re-used.  All timeout keyword arguments are
-only available for LispWorks, WRITE-TIMEOUT is only available for
-
+
+
+
+
+
+
-  (unless (member protocol '(:http/1.0 :http/1.1) :test #'eq)
-    (error "Don't know how to handle protocol ~S." protocol))
@@ -444 +450 @@
-                                    (usocket:socket-stream
-                                     (usocket:socket-connect host port :element-type 'octet))))
+              #+openmcl
+              (when deadline
+                (setf (ccl:stream-deadline http-stream)
+                      (+ (get-internal-real-time)
+                         (* (- deadline (get-universal-time)) internal-time-units-per-second))))
-              (when (and use-ssl
-                         ;; don't attach SSL to existing streams