;;; Linkit source code (remember that it's a quick and dirty hack written in 7 hours only) ;;; All the database and web stuff is handled automagically by the Fractal Framework. ;;; copyrigth (c) Marc Battyani 2005 (in-package linkit) (defun home-page-fn() (html:html (:h1 "LinkIt: The improved one...") (:h2 "Disclaimer:") (:p "This small site has been written in 7 hours in Common Lisp just as a proof of concept.") (:p "Obviously it's a work in progress. For instance there is no ranking yet because we would like to find a better way of doing it rather than implementing the easy one.") (:p "It is hosted on a dual 2.8GHz PC running Debian behind a residential ADSL line. So don't expect a blazing connection speed...") (:p ((:a :href #e"hot") "Enter linkit")))) (make-instance 'page-desc :name "home" :title-en "Home" :content-en '((home-page-fn))) (make-instance 'page-desc :name "object" :title-en "Object" :content-en `((:object-view) :connect-views :br)) (make-instance 'page-desc :name "hot" :title-en "Hot links" :content-en '((:h1 "Hot Links") (print-link-list (hot-link-list *sys-params*)))) (make-instance 'page-desc :name "new" :title-en "New links" :content-en '((:h1 "New Links") (print-link-list (full-link-list *sys-params*)))) (make-instance 'page-desc :name "top" :title-en "Top links" :content-en '((:h1 "Top Links") (print-link-list (top-link-list *sys-params*)))) (make-instance 'page-desc :name "profile" :title-en "My Profile" :content-en '((:object-view :object *user* :name "user-p") :connect-views)) (make-instance 'page-desc :name "admin" :title-en "Administration" :content-en '((:object-view :object *sys-params* :name "sys-a") :connect-views)) (defun submit-page-fn () (html:html (:object-view :object (new-link *user*)) :connect-views )) (make-instance 'page-desc :name "submit" :title-en "Submit link" :content-en '((:object-view :object (new-link *user*)) :connect-views )) (defun submit-link (link) (push link (full-link-list *sys-params*)) (setf (status link) :published) (incf (nb-published-links (creator link))) (setf (new-link (meta::parent link)) nil) (recompute-link-lists) (interface::send-url-to-interface (interface::encode-session-url nil (list :session (interface::id *session*) :lang interface::*country-language-id* :page "new")))) (defun recompute-link-lists () (setf (hot-link-list *sys-params*)(sort (full-link-list *sys-params*) #'> :key 'nb-points) (top-link-list *sys-params*)(sort (full-link-list *sys-params*) #'> :key 'nb-points))) (defun intersect (link-features user-features) (dolist (feature link-features) (when (member feature user-features) (return t)))) (defun filter-link-color (link user) (if user (if (member (creator link) (display-submitter-list user)) (display-submitter-color user) (if (member (creator link) (hide-submitter-list user)) (if (use-hide-submitter-filter user) nil (if (use-display-submitter-filter user) nil (hide-submitter-color user))) (if (use-display-submitter-filter user) nil (if (intersect (category-list link) (hide-category-list user)) (if (use-hide-category-filter user) nil (hide-category-color user)) (if (intersect (category-list link) (display-category-list user)) (display-category-color user) (if (use-display-category-filter user) nil "#FFFFFF")))))) "#FFFFFF")) (defun print-link (link rank color) (html:html (:tr ((:td :rowspan "2") rank) ((:td :rowspan "2") ((:a :href "" #+nil (interface::encode-object-url link)) ((:img :border "0" :src "/a2.png"))):br ((:a :href "" #+nil(interface::encode-object-url link)) ((:img :border "0" :src "/a4.png")))) ((:td :style (concatenate 'string "background-color:" color)) ((:a :href (url link) :style "font-size:12pt;") (:esc (title link))))) (:tr ((:td :style "font-size:9pt;") (:fformat "~d points " (nb-points link)) "Submitted by " ((:a :href (interface::encode-object-url (creator link))) (:esc (meta::short-description (creator link)))) " [" (loop for cat in (category-list link) for first = t then nil repeat 5 do (html:html (:when (not first) ", ") ((:a :href (interface::encode-object-url cat))(:esc (name cat))))) "]")) ((:tr :height "5px")(:td " ")))) (defun print-link-list (list) (html:html ((:table :cellspacing "0" :cellpadding "0" :width "100%" :border "0") (loop with rank = 0 for link in list for color = (filter-link-color link *user*) until (= rank 50) do (when color (incf rank) (print-link link rank color)))))) (defun get-category (obj) (category-list *sys-params*)) (defun add-to-display-submitter-list (obj) (when *user* (pushnew obj (display-submitter-list *user*)))) (defun add-to-hide-submitter-list (obj) (when *user* (pushnew obj (hide-submitter-list *user*)))) (defmethod new-link :around ((obj appli-user)) (let ((new-link (call-next-method))) (unless new-link (setf new-link (make-instance 'link :parent obj) (creator new-link) obj (new-link obj) new-link)) new-link)) (defmethod new-link :around ((obj anonymous-user)) nil) (defmethod interface::groups ((user appli-user)) (let ((groups '(:user))) (when (admin user) (push :admin groups)) (when (dev user) (push :dev groups)) (when (validator user)(push :validator groups)) groups)) (make-instance 'interface::object-view :object-class 'sys-params :special-view t :country-languages '(:fr :en) :name "sys-p" :source-code '((:slot-table pending-link-list))) (make-instance 'interface::object-view :object-class 'sys-params :special-view t :country-languages '(:fr :en) :name "sys-a" :source-code '((:slot-table category-list user-list full-link-list))) (make-instance 'interface::object-view :object-class 'appli-user :special-view t :country-languages '(:fr :en) :name "user-p" :source-code '((:slot-table identifier email nb-points nb-published-links last-access creation-date admin validator dev password) (:on-off ((:a :href "#") ((:img :height "9" :src "/arblue.gif" :width "9" :border "0")) (:translate '(:fr " Hide " :en " Hide "))) ((:a :href "#") ((:img :height "9" :src "/arblue.gif" :width "9" :border "0")) (:translate '(:fr " Filtre pas catégories" :en " Categories filter"))) (:slot-table use-display-category-filter use-hide-category-filter display-category-color hide-category-color display-category-list hide-category-list)) :br (:on-off ((:a :href "#") ((:img :height "9" :src "/arblue.gif" :width "9" :border "0")) (:translate '(:fr " Hide " :en " Hide "))) ((:a :href "#") ((:img :height "9" :src "/arblue.gif" :width "9" :border "0")) (:translate '(:fr " Filtre par submitteurs" :en " Submitters filter"))) (:slot-table use-display-submitter-filter use-hide-submitter-filter display-submitter-color hide-submitter-color display-submitter-list hide-submitter-list)) :br)) (make-instance 'interface::object-view :object-class 'appli-user :special-view nil :country-languages '(:fr :en) :name "user-v" :source-code '((:slot-table identifier nb-points nb-published-links creation-date) (:obj-fn-table) (:h2 "Published Links") (print-link-list (remove *object* (full-link-list *sys-params*) :test-not #'eq :key #'creator)))) (make-instance 'interface::object-view :object-class 'category :special-view nil :country-languages '(:fr :en) :name "cat1" :source-code '((:when-groups '(:admin :validator) (:slot-table name description)) (:h1 "Category: " (:esc (name *object*))) (:p (:i (:esc (description *object*)))) (:h2 "Related Links") (print-link-list (remove-if #'(lambda (link) (not (member *object* (category-list link)))) (full-link-list *sys-params*))))) (defun write-page (s content-func title) (ensure-user) (html:html-to-stream s "" (:html (:head (:title "LinkIt") ((:meta :http-equiv "Content-Type" :content "text/html; charset=iso-8859-1")) ((:link :rel "stylesheet" :type "text/css" :href "/linkit.css"))) ((:body) ((:img :border "0" :src "/logo.png"))((:img :border "0" :src "/glossy120.jpg")) ((:table :cellspacing "0" :cellpadding "0" :width "100%" :border "0") (:tr ((:td ) " ")) ((:tr :style "background-color:#e0e0ff;") (:td ((:table :cellspacing "0" :cellpadding "0" :border "0" :style "background-color:#e0e0ff;") ((:tr :style "background-color:#e0e0ff;") (:td "    " ((:a :href #e"hot") "Hot")) (:td "  " ((:a :href #e"new") "New")) (:td "  " ((:a :href #e"top") "Top")) (:when-groups '(:user) (:td "  " ((:a :href #e"submit") "Submit")) (:td "  " ((:a :href #e"profile") "My Profile"))) (:when-groups '(:admin :validator) (:td "  " ((:a :href #e"admin") "Admin"))))))) ((:tr :style "background-color:#b0b0ff;" ) ((:td :align "left" :aacolspan "4") ((:table :style "background-color:#b0b0ff;" :cellspacing "0" :cellpadding "0" :border "0") (:tr ((:td ) " ") ((:td ) ((:div :style "width:200px;") " ")) ((:td ) (html:esc (html:universal-time-to-date interface::*session-timer-time* *country-language*))) ((:td ) "|") ((:td ) (if *user* (html:esc (meta::short-description *user*)) ""))))))) ((:div :style "padding:5px;") :use-ui (check-authentification interface::*session*) (funcall content-func))))))