Component web-server

You are here: All Systems / lisppaste / web-server

;;;; $Id: web-server.lisp,v 1.105 2008/08/14 13:17:05 lisppaste Exp $
;;;; $Source: /project/lisppaste/cvsroot/lisppaste2/web-server.lisp,v $

;;;; See the LICENSE file for licensing information.

(in-package :lisppaste)

(defclass paste ()
  ((number :initarg :number :initform 0 :accessor paste-number)
   (user :initarg :user :initform "" :accessor paste-user)
   (title :initarg :title :initform "" :accessor paste-title)
   (contents :initarg :contents :initform "" :accessor paste-contents)
   (universal-time :initarg :universal-time :initform 0 :accessor paste-universal-time)
   (annotations :initarg :annotations :initform nil :accessor paste-annotations)
   (annotation-counter :initarg :annotation-counter :initform 0 :accessor paste-annotation-counter)
   (channel :initarg :channel :initform "" :accessor paste-channel)
   (colorization-mode :initarg :colorization-mode :initform "" :accessor paste-colorization-mode)
   (maybe-spam :initarg :maybe-spam :initform nil :accessor paste-maybe-spam-p)
   (is-unicode :initarg :is-unicode :initform :true :accessor paste-is-unicode-p)))

(defun paste-display-url (paste)
  (urlstring (merge-url *display-paste-url* (prin1-to-string (paste-number paste)))))

(defun find-paste (number)
  (find number *pastes* :key #'paste-number))

(defmacro make-paste (&rest arguments)
  `(progn
    (funcall 'make-instance 'paste ,@arguments)))

(defclass lisppaste-basic-behavior () ())

(defclass lisppaste-basic-handler (handler lisppaste-basic-behavior) ())

(defclass main-handler (lisppaste-basic-handler) ())

(defclass recent-handler (lisppaste-basic-handler) ())

(defclass css-handler (lisppaste-basic-handler) ())

(defclass new-paste-handler (lisppaste-basic-handler) ())

(defclass list-paste-handler (lisppaste-basic-handler) ())

(defclass submit-paste-handler (lisppaste-basic-handler) ())

(defclass display-paste-handler (lisppaste-basic-handler) ())

(defclass rss-handler (lisppaste-basic-handler) ())

(defclass rss-full-handler (lisppaste-basic-handler) ())

(defclass syndication-handler (lisppaste-basic-handler) ())

(defclass stats-handler (lisppaste-basic-handler) ())

(defclass email-redirect-handler (lisppaste-basic-handler) ())

(defclass channel-select-handler (lisppaste-basic-handler) ())

(defclass 404-handler (handler) ())

(define-application lisppaste-application *paste-listener*)

(defclass admin-mixin () ())

(define-handler-hierarchy (:application lisppaste-application)
    (*paste-external-url*
     ("mark-as-spam" (mark-as-spam-handler lisppaste-basic-behavior) :inexact t)
     ("mark-as-wrong-channel" (mark-as-wrong-channel-handler lisppaste-basic-behavior) :inexact t)
     ("administration" (administration-handler lisppaste-basic-behavior admin-mixin))
     ("administration/"
      ("login" (login-handler lisppaste-basic-behavior))
      ("logout" (logout-handler lisppaste-basic-behavior))
      ("kill-paste" (kill-paste-handler lisppaste-basic-behavior admin-mixin))
      ("spam-review" (spam-review-handler lisppaste-basic-behavior admin-mixin)))))

(defvar *referer-hash* (make-hash-table :test #'equalp))

(defvar *referer-example-hash* (make-hash-table :test #'equalp))

(defun times-file-for-class (class)
  (merge-pathnames (format nil "times-~(~A~)"
                           (symbol-name (class-name (class-of class))))
                   *times-file-root*))

(defun referer-list ()
  (loop for link being the hash-values of *referer-example-hash* using (hash-key host)
        collect (cons host link)))

(defun fix-referers ()
  (loop for count being the hash-values of *referer-hash* using (hash-key host)
        do (let ((split-host (split-sequence:split-sequence #\. host)))
             (when (or
                    (and (eql (length split-host) 3)
                         (string-equal (first split-host) "www")
                         (string-equal (second split-host) "google"))
                    (and (eql (length split-host) 4)
                         (string-equal (first split-host) "www")
                         (string-equal (second split-host) "google")
                         (or
                          (string-equal (third split-host) "co")
                          (string-equal (third split-host) "com"))
                         (eql (length (fourth split-host)) 2)))
               (remhash host *referer-hash*)
               (incf (gethash "Google" *referer-hash* 0) count)))))

(defvar *show-captcha* t)

(defmethod handle-request-response :around ((handler lisppaste-basic-behavior) method request)
  (with-open-file (*trace-output* (times-file-for-class handler)
                                  :direction :output
                                  :if-exists :append :if-does-not-exist :create)
    (expire-authorization-tokens)
    (unwind-protect
         (let ((*show-captcha* (not (is-authorized request))))
           (call-next-method))
      (force-output *trace-output*))))

(defun make-css ()
  (let ((colorize:*css-background-class* "paste"))
    (format nil "body { background: white; color: black; }
a { margin:1px; border-collapse: collapse; }
a:link { color:#335570; text-decoration: none; background-color: transparent;}
a:visited { color:#705533; text-decoration: none; background-color: transparent;}
a:hover { color:#000000; text-decoration: none; background-color: #BBCCEE; border: 1px solid #335577; margin: 0px;}
a:active { color:#000000; text-decoration: none; background-color: #CCBBFF; border: 1px solid #335577; margin: 0px;}
.simple-paste-list { background-color : #E9FFE9 ; border: 2px solid #9D9; padding : 4px; font-size: small; }
.simple-paste-list td { border-bottom: 1px dotted #9D9; font-size: small; }
table.detailed-paste-list { border-collapse: collapse; border : 1px solid #AAA ; }
table.detailed-paste-list td { border : 1px dotted #AAA; }
table.info-table { border-collapse: collapse; border : 1px solid #AAA ; background-color: #F9E9F9; empty-cells: hide; }
table.info-table td { border : 1px dotted #AAA; background-color: transparent; padding-left: 2em; padding-right: 2em; }
table.info-table th { border : 1px dotted #AAA; background-color: transparent; text-align: left; padding-right: 1em; }
table.rate-table { border-collapse: collapse; border : 1px solid #AAA ; background-color: #F9E9F9; empty-cells: hide; }
table.rate-table td { border : 1px dotted #AAA; background-color: transparent; padding: 2pt; }
table.rate-table th { border : 1px dotted #AAA; background-color: transparent; text-align: left; padding: 1pt; }
.new-paste-form { background-color : #FFE9E9 ; border: 2px solid #D99; padding : 4px; }
.paste-header { background-color : #E9F9F9 ; border: 2px solid #9DD; padding : 4px; margin-bottom : 4px; }
.info-text { background-color : #E9F9F9 ; border: 2px solid #9DD; padding : 4px; margin-top : 4px; text-align: justify; }
div.ads-text { background-color : #F9E9F9 ; border: 2px solid #D9D; padding : 4px; margin-top : 4px; text-align: justify; font-size: small; display: table; padding-right: 1em; }
div.ads-text ul { margin-top: 0; margin-bottom: 0; padding-top: 0; padding-bottom: 0; }
div.ads-text li { padding-bottom: 1ex; }
.ohloh a:link { margin: 0px; border-collapse: collapse; border: 0; }
.ohloh a:active { margin: 0px; border-collapse: collapse; border: 0; }
.ohloh a:visited { margin: 0px; border-collapse: collapse; border: 0; }
.ohloh a:hover { margin: 0px; border-collapse: collapse; border: 0; }
.controls { background-color : #E9E9FF ; border: 2px solid #99D; padding : 4px; display: inline-block; }
.small-header { font-weight: bold; font-size: large; }
.top-header { text-align : center; font-style: italic; font-weight: bold; font-size: x-large; }
.big-warning { text-align : center; font-weight: bold; font-size: x-large; }
.paste-area { background-color : #F4F4F4 ; border : 2px solid #AAA ; }
.bottom-links { background-color : #F9F9E9; border: 2px solid #DD9; padding : 4px; margin-bottom : 4px;}
#main-link { text-align : left; font-weight: bold; }
#other-links { text-align : right; }
hr { border: 1px solid #999; }
@media screen {
div.altdiv { display: none; }
}
table.webutils-form { background-color : #E9E9FF ; border: 2px solid #99D; padding : 4px; }
table.webutils-form th { text-align: left; }
~A~&~A~&"
            (colorize:make-background-css "#F4F4F4")
            colorize:*coloring-css*)))

(defmethod handle-request-response ((handler css-handler) method request)
  (request-send-headers request :expires 0 :content-type "text/css")
  (html-stream
   (request-stream request)
   (make-css)))

(defun rss-link-header ()
  <link rel="alternate" type="application/rss+xml" title="Lisppaste RSS" href=?(urlstring *rss-url*)/>)

(defparameter *form-accept-translator* (make-translator))

(define-translator *form-accept-translator* mutate-forms
  (:oaoo <form $attributes> . body)
  (<form accept-charset= "utf-8" $attributes> body))

(defun lisppaste-wrap-page (title &rest forms)
  (<html>
   (<head> (<title> title)
           <link type="text/css" rel="stylesheet" href=?(url-path *css-url*)/>
           (rss-link-header))
   (<body>
    (<div class="top-header"> title)
    <p/>
    (apply-translator *form-accept-translator* forms)
    (bottom-links))))

(defun bottom-links ()
  (list
   <p/>
   (<div class="bottom-links">
         (<table width="100%">
                 (<tr>
                  (<td id="main-link">
                       (<a href=?(urlstring *paste-external-url*)> "Main page"))
                  (<td id="other-links">
                       (<a href=?(urlstring *new-paste-url*)> "New paste")
                       " | "
                       (<a href=?(urlstring *list-paste-url*)> "List all pastes")
                       " | "
                       (<a href=?(urlstring *syndication-url*)> "Syndication")
                       " | "
                       (<a href="http://common-lisp.net/project/lisppaste/xml-rpc.html"> "XML-RPC")
                       (when *serve-source*
                         (list " | "
                               (<a href=?(urlstring (merge-url *show-component-url* "lisppaste"))>
                                   "Source")))
                       " | "
                       (<a href=?(urlstring *email-redirect-url*)> "Requests Email")
                       " | "
                       (<a href=? (urlstring (handler-url 'administration-handler))> "Administrate")
                       " | "
                       (<a href="http://www.common-lisp.net/project/lisppaste"> "Project home")))))
   (<i> "Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.")))

(defmethod application-wrap-page ((application-handler lisppaste-application) request title body &rest extra-headers)
  (apply #'request-send-headers request :expires 0 :content-type "text/html; charset=utf-8" extra-headers)
  (xml-output-to-stream (request-stream request)
                        (lisppaste-wrap-page title body)))

(defun lisppaste-send-headers-for-html (request)
  (request-send-headers request :expires 0 :content-type "text/html; charset=utf-8"))

(defun recent-paste-list-div (&key (count 10))
  (<div class="simple-paste-list">
        (<table>
         (loop for i from 1 to count
              for j in *pastes*
              collect (<tr>
                       (<td valign="center"> (<a href=?(paste-display-url j)>
                                                 (paste-title j)))
                       (<td valign="bottom"> " by " (paste-user j))
                       (<td valign="bottom"> (paste-channel j))))
         (<tr> (<td colspan="3">
                    (<center> (<b> (<a href=?(urlstring *list-paste-url*)>
                                       "More recent pastes..."))))))))

(defmethod handle-request-response ((handler recent-handler) method request)
  (lisppaste-send-headers-for-html request)
  (xml-output-to-stream
   (request-stream request)
   (lisppaste-wrap-page
    "Recent Pastes"
    (recent-paste-list-div :count 20))))

(defmethod handle-request-response ((handler main-handler) method request)
  (lisppaste-send-headers-for-html request)
  (xml-output-to-stream
   (request-stream request)
   (lisppaste-wrap-page
    (format nil "~A pastebin" *paste-site-name*)
    (<table width="100%" border="0" cellpadding="2">
            (<tr> (<td> (<div class="small-header"> "Recent Pastes"))
                  (<td align="right"> (<div class="small-header"> "Make a new paste")))
            (<tr> (<td valign="top" width="40%">
                       (recent-paste-list-div)
                       <p/>
                       (<div class="small-header"> "About lisppaste")
                       (<div class="info-text">
                             "Lisppaste is a pastebot / pastebin / nopaste service with syntax highlighting, XML-RPC support, annotations, and more."
                             <p/>
                             "Many times when working via IRC, people
want to share a snippet of code with somebody else. However, just
pasting the code into IRC creates a flood of text which is hard to
read and scrolls by as discussion progresses."
                             <p/>
                             "Thus, the pastebot was invented, which
has a web form where users can paste code, and the URL of the paste is
announced on the desired channel. Lisppaste is an advanced pastebot
running on the IRC server "
                             *irc-network-name*
                             " which has many unique features."
                             (when *no-channel-pastes*
                         (list
                          <p/>
                          "It also allows pastes which are not
announced on any channel, which is useful for sections of code which
need to be sent to a mailing list or are discussed in ways other than
IRC."
                          <p/>
                          "Lisppaste is graciously hosted by "
                          (<b> (<a href="http://www.common-lisp.net/"> "common-lisp.net"))
                          " - a hosting service for projects written in Common Lisp (like this one)."
                          <p/>
                          "Questions? Comments? Want lisppaste in your channel? "
                          (<a href=?(urlstring *email-redirect-url*)> "Email me")
                       "."))))
                  (<td valign="top" align="right">
                       (<form method="post" action=?(urlstring *submit-paste-url*)>
                              (generate-new-paste-form :width 60))
                       <p/>
                       *ohloh*
                       (<div class="ads-text"> *ads*)))))))

(defun ban-log (user request)
  (log-event
   (format nil "Blocked attempt by ~S, IP ~S, (referred by ~S) to submit a paste.~%Request headers are: ~S.~%Request body is: ~S.~%"
           user
           (car (request-header request :x-forwarded-for))
           (car (request-header request :referer))
           (request-headers request)
           (request-body request))
   :log-file *ban-log-file*))

(defmethod handle-request-response :around
    ((handler submit-paste-handler) method request)
  (let ((forwarded-for (car (request-header request :x-forwarded-for))))
    (if (and forwarded-for
                 (member forwarded-for
                         *banned-ips* :test #'string-equal))
        (progn
          (ban-log forwarded-for request)
          (lisppaste-send-headers-for-html request)
          (xml-output-to-stream
           (request-stream request)
           (<html> (<head> <title> "No cookie for you!")
                   (<body> (<h1> (<font color="red"> "Naughty boy!"))))))
        (call-next-method))))

(defmethod handle-request-response ((handler new-paste-handler) method request)
  (let* ((annotate-string (body-param "annotate" (request-body request)))
         (annotate-number (if annotate-string (parse-integer annotate-string :junk-allowed t)))
         (annotate (if annotate-number (find annotate-number *pastes* :key #'paste-number)))
         (default-channel
             (or (and annotate (paste-channel annotate))
                 (find-if #'(lambda (e) (> (length e) 1))
                          (list
                           (and (eql method :post)
                                (body-param "channel"
                                                     (request-body request)))
                           (substitute #\# #\/ (urlstring-unescape (request-unhandled-part request)) :test #'char=)
                           (concatenate 'string "#" (request-cookie request "CHANNEL"))
                           (and *no-channel-pastes*
                                "None")
                           )))))
    (cond
      ((and default-channel (or (and *no-channel-pastes*
                                     (string-equal default-channel "None"))
                                (find default-channel *channels* :test #'string-equal)))
       (request-send-headers request :expires 0
                             :content-type "text/html; charset=utf-8"
                             :set-cookie
                             (format nil "CHANNEL=~A; path=/"
                                     (or (and *no-channel-pastes*
                                              (string-equal default-channel "none")
                                              "None")
                                         (subseq default-channel 1))))
       (new-paste-form request :annotate annotate :default-channel default-channel))
     (t (lisppaste-send-headers-for-html request)
        (xml-output-to-stream
         (request-stream request)
         (lisppaste-wrap-page
          "Select a channel"
          (<form method="post" action=?(urlstring *new-paste-url*)>
                 (<div class="controls">
                       <input type="hidden" name="annotate" value=?annotate-string />
                       "Please select a channel to lisppaste to: "
                               (<select name="channel">
                                        (<option value=""> "")
                                        (mapcar (lambda (e)
                                                  (<option value=?e> e))
                                                *channels*))
                       <input type="submit" value="Submit"/>))))))))

(defun time-delta (time &key (level 2) (ago-p t) (origin (get-universal-time)))
  (let ((delta (- origin time)))
    (cond
     ((< delta 1) "&lt;Doc Brown&gt;From the <i>future</i>...&lt;/Doc Brown&gt;")
     ((< delta (* 60 60)) (format nil "~A~A" (time-delta-primitive delta 1) (if ago-p " ago" "")))
     (t (format nil "~A~A" (time-delta-primitive delta level) (if ago-p " ago" ""))))))

(defun irc-log-link (utime channel)
  (format nil "http://ircbrowse.com/cview.html?utime=~A&channel=~A&start=~A&end=~A#utime_requested"
          (- utime 5)
          (string-left-trim "#" channel)
          (- utime (* 60 60))
          (+ utime (* 60 60))))

(defun first-<-mod (n &rest nums)
  (some #'(lambda (n2)
            (if (< n2 n) (mod n n2) nil)) nums))

(defun time-delta-primitive (delta &optional (level 2))
  (let* ((seconds 60)
         (minutes (* seconds 60))
         (hours (* minutes 24))
         (days (* hours 7))
         (weeks (* hours 487/16))
         (months (* weeks 12))
         (years (* hours (+ 365 1/4))))
    (let ((primitive
           (cond
            ((< delta seconds) (format nil "~D second~:P" delta))
            ((< delta minutes) (format nil "~D minute~:P" (floor delta seconds)))
            ((< delta hours) (format nil "~D hour~:P" (floor delta minutes)))
            ((< delta days) (format nil "~D day~:P" (floor delta hours)))
            ((< delta weeks) (format nil "~D week~:P" (floor delta days)))
            ((< delta months) (format nil "~D month~:P" (floor delta weeks)))
            (t (format nil "~D year~:P" (floor delta months))))))
      (if (eql level 1) primitive
        (format nil "~A, ~A" primitive
                (time-delta-primitive
                 (first-<-mod delta years months weeks days hours minutes seconds)
                 (1- level)))))))

(defun max-length (str n)
  (if (> (length str) n)
      (concatenate 'string (subseq str 0 (1- n)) "...")
    str))

(defmethod handle-request-response ((handler syndication-handler) method request)
  (lisppaste-send-headers-for-html request)
  (xml-output-to-stream
   (request-stream request)
   (lisppaste-wrap-page
    "Syndication options"
    "Lisppaste can be syndicated in a variety of RSS formats for use
with your favorite RSS reader."
    <p/>
    (<table class="info-table">
            (<tr>
             (<th align="left"> "All channels")
             (<td> (<a href=?(urlstring *rss-url*)> "Basic"))
             (<td> (<a href=?(urlstring *rss-full-url*)> "Full")))
            (mapcar (lambda (channel)
                      (let ((append (if (and *no-channel-pastes*
                                             (string-equal channel "None"))
                                        "?none"
                                        (substitute #\? #\# channel))))
                        (<tr>
                         (<th align="left"> channel)
                         (<td> (<a href=?(concatenate 'string
                                                      (urlstring *rss-url*)
                                                      append)>
                                   "Basic"))
                         (<td> (<a href=?(concatenate 'string
                                                      (urlstring *rss-full-url*)
                                                      append)>
                                   "Full")))))
                    *channels*)))))

(defun last-paste-date-for-channel (channel)
  (let ((paste (find channel *pastes* :test #'string-equal :key #'paste-channel)))
    (if paste
        (time-delta (paste-universal-time paste) :level 1 :ago-p nil)
        "Never")))

(defmethod handle-request-response ((handler channel-select-handler) method request)
  (lisppaste-send-headers-for-html request)
  (xml-output-to-stream
   (request-stream request)
   (lisppaste-wrap-page
    (format nil "~A channel list" *paste-site-name*)
    (<table width="100%" border="0" cellpadding="2">
            (<tr valign="top" align="center">
                 (<td>
                  (<div class="info-text">
                        "Lisppaste is available in "
                        (<b> (prin1-to-string
                              (length (remove "None" *channels* :test #'equal))))
                        (format nil " channels on the IRC network ~A. Select a channel from the list below and bookmark its URL to paste with direct notification to your channel." *irc-network-name*)
                        <p/>
                        "Questions? Comments? Want lisppaste in your channel? "
                        (<a href=?(urlstring *email-redirect-url*)> "Email me")
                        ".")
                  <p/>
                  (<table class="info-table">
                          (<tr>
                           (<th align="left"> "Channel Name")
                           (<th align="left"> "")
                           (<th align="left"> "")
                           (<th align="left"> "Last Paste"))
                          (mapcar (lambda (channel)
                                    (<tr>
                                     (<th align="left">
                                          channel)
                                     (<th align="left">
                                          (<a href=?(concatenate 'string
                                                                 (urlstring *new-paste-url*)
                                                                 "/"
                                                                 (urlstring-escape (subseq channel 1)))>
                                              "New paste here"))
                                     (<th align="left">
                                          (<a href=?(concatenate 'string
                                                                 (urlstring *list-paste-url*)
                                                                 "/"
                                                                 (urlstring-escape (subseq channel 1)))>
                                              "List"))
                                     (<td align="left">
                                          (last-paste-date-for-channel channel))))
                                  (sort (remove "None" *channels* :test #'string-equal) #'string<)))))))))
  
(defmethod handle-request-response ((handler stats-handler) method request)
  (lisppaste-send-headers-for-html request)
  (xml-output-to-stream
   (request-stream request)
   (lisppaste-wrap-page
    "Statistics"
    (<div>
     (<span class="small-header"> "Uptime: ")
     (time-delta *boot-time* :ago-p nil :level 3)))))

(defmethod handle-request-response (