#!/usr/local/bin/munger

; SCGI Blog Application Server Copyright (c) 2009-2011, James Bailie.
; All rights reserved.
;
; Redistribution and use in source form, with or without
; modification, is permitted provided that the following conditions are met:
;
;     * Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;     * The name of James Bailie may not be used to endorse or promote
; products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS"
; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.

; -----------------------------------------------------------------------

; This script implements a blog as an SCGI application server.

; -----------------------------------------------------------------------

; The server must be started as root.  Use the rc script to
; start/stop/restart.  It does the following for you:

; To stop the server issue the following three commands in the order
; presented:

; kill -9 `cat /var/run/ephemera/master`
; kill -9 `cat /var/run/ephemera/slave*`
; rm /var/run/ephemera/*

; The master process must be killed before the slaves or the master will
; restart the slaves.

; -----------------------------------------------------------------------

; Makes errors fatal to interpreter.

(fatal)

; Speeds things up by making GC occur more often, but with less garbage to
; clean up.

(gc_freq 8192)

; Newline and carriage return.

(setq nl (char 10))
(setq cr (char 13))

(setq ephemera_version "2.9")

; Need Munger 4.174 or higher, with SQLite interface.

(let ((v (version)))
   (unless (or (> (car v) 4) 
               (and (>= (car v) 4) (>= (cadr v) 174)))
      (die "Ephemera " ephemera_version " requires Munger 4.174 or higher.")))
   
(unless (boundp 'sqlite_open)
   (die "Ephemera requires Munger's SQLite interface." nl
        "Change to /usr/ports/munger and invoke \"make config\"," nl
        "turn on the sqlite option, then invoke" nl
        "\"make clean deinstall install clean\"."))

; Load configuration options.

(load "/usr/local/etc/ephemera.config")

(let ((vars '(interface port user group num_servers max_servers page_size
              rss_page_size host path name static_main stylesheet db_path
              db_name title title_image favicon meta_description
              meta_language meta_keywords meta_robots rss_description
              before after)))

   (while vars
      (when(not (boundp (car vars)))
         (die (car vars) " not defined in /usr/local/ephemera.config"))

      (setq vars (cdr vars))))

(when (< (length static_main) 4)
   (die "As of Ephemera 2.8, static_main now requires four elements." nl
        "See /usr/local/etc/ephemera.config.dist for details."))

; ------------------------------------------------------------------------

; SCGI Helper Functions.

; ------------------------------------------------------------------------

; Sends all http/html headers for an XHTML document with a STRICT DTD,
; and opens <body> element.

(defun send_headers ((static))

   ; Don't send HTTP header if we are generating the static main page.

   (print (if static "" (concat "Content-Type: text/html" cr nl cr nl))

      "<!DOCTYPE html>" nl
      "<html>" nl
      "<head>" nl
      "<meta name=\"generator\" content=\"ephemera " ephemera_version "\" />" nl

      (if (and (boundp 'meta_description) meta_description)
         (concat "<meta name=\"description\" content=\"" meta_description "\" />"
                 nl)
         "")

      (if (and (boundp 'meta_keywords) meta_keywords)
         (concat "<meta name=\"keywords\" content=\"" meta_keywords "\" />"
                 nl)
         "")

      (if (and (boundp 'meta_language) meta_language)
         (concat "<meta name=\"language\" content=\"" meta_language "\" />"
                 nl)
         "")

      (if (and (boundp 'meta_robots) meta_robots)
         (concat "<meta name=\"robots\" content=\"" meta_robots "\" />"
                 nl)
         "")

      nl

      ; Link elements to stylesheet and favicon.

      "<link rel=\"stylesheet\" media=\"screen\" href=\""
      stylesheet "\" type=\"text/css\" />" nl
      "<link rel=\"shortcut icon\" href=\"" favicon "\" />" nl

      "<link rel=\"alternate\" type=\"text/xml\" title=\"" 
         title "\" href=\"" 
          (if static_main
             (cadddr static_main)
             (concat path name "?request=send_rss")) 
         "\" />"

      (if (and (boundp 'javascript) javascript)
         (concat "<script type=\"text/javascript\" src=\""
                 javascript "\"></script>")
         "")

      nl nl

      ; Title.

      "<title>" title "</title>" nl "</head>" nl nl

      ; Close the head and open the body element.

      "<body>"))

; Gets key/value pairs encoded with x-www-form-urlencoding.

(let ((d ""))

   (defun get_data ()

      ; clear out any old parameters from the last invocation.

      (foreach (lambda (x) (unhash data x)) (keys data))

      ; Get the new parameters.

      (if (eq (and (boundp 'REQUEST_METHOD) REQUEST_METHOD) "GET")
         (setq d (if (boundp 'QUERY_STRING) QUERY_STRING ""))
         (setq d body))

      (if (not d)
         0

         (foreach (lambda (x)
                     (hash data (form_decode (car x))
                        (if (cdr x) (form_decode (cadr x)) "")))

                  (mapcar (lambda (x) (split "=" x))
                          (split "&" d)))

         1)))

(setq data (table))

; ------------------------------------------------------------------------

; Blog functions.

; ------------------------------------------------------------------------

(setq string_page_size (stringify page_size))

(let ((amp_rx (regcomp "&"))
      (apos_rx (regcomp "'"))
      (quot_rx (regcomp "\""))
      (lt_rx (regcomp "<"))
      (gt_rx (regcomp ">"))
      (tag_rx (regcomp "<[^>]*(>|$)"))
      (like_rx (regcomp "[%_\\\\]")))

   ; Used to sanitize RSS titles and links.  We convert XML-significant
   ; characters to their entity references.

   (defun escape_markup (txt)
      (substitute gt_rx "&gt;"
         (substitute lt_rx "&lt;"
            (substitute quot_rx "&quot;"
               (substitute apos_rx "&apos;"
                  (substitute amp_rx "&amp;" txt 0) 0) 0) 0) 0))

   ; Remove markup from RSS descriptions.

   (defun remove_markup (txt)
      (escape_markup (substitute tag_rx "" txt 0)))

   ; Used to sanitize search keys displayed in <h2> header of search
   ; results.  We remove tags and lone angle brackets and ampersands,
   ; because they are removed from search keys to prevent matching markup.

   (defun sanitize_html (txt)
      (substitute gt_rx ""
         (substitute lt_rx ""
            (substitute tag_rx ""
               (substitute amp_rx "" txt 0) 0) 0) 0))

   ; Used to sanitize search keys for SQLite.  We escape LIKE-significant
   ; characters, % and _ and the ESCAPE character '\'.  We also remove
   ; tags, and lone < and > characters, and & from search keys so we don't
   ; match markup.  The ESCAPE character is defined to be the backslash in
   ; the call to sqlite_prepare to init the search_sql global.

   (defun escape_like (txt)
      (substitute amp_rx ""
         (substitute lt_rx ""
            (substitute gt_rx ""
               (substitute tag_rx ""
                  (substitute like_rx "\\\\\&" txt 0) 0) 0) 0) 0)))

; Indicates where permalink will be sent with each article or not.
; Only used by send_one and print_each.

(setq permalink 1)

; Creates and/or opens the database.  The database handle
; is bound to db.

(let ((db_file (concat db_path db_name))
      (result ""))

   (defun open_db ()
      (when (stringp (setq db (sqlite_open db_file)))
         (die "sqlite_open: " db))

      ; Ensure the index on Time exists.  Older versions of ephemera did not
      ; create it when they created the database.

      (setq result
         (sqlite_exec db "CREATE INDEX IF NOT EXISTS t_idx ON Articles ( Time )"))

      (when (stringp result)
         (die "sqlite_exec: " result)))

   (defun create_db ()
      (setq result (exists db_file))

      (cond ((eq result 0)
             (when (stringp (setq db (sqlite_open db_file)))
                (die "sqlite_open: " db))

             (setq sql
                (concat "CREATE TABLE Articles ( Id TEXT PRIMARY KEY UNIQUE, Date TEXT, "
                   "Title TEXT, Body TEXT, Time INTEGER );"
                   "CREATE INDEX t_idx ON Articles ( Time )"))

             (when (stringp (setq result (sqlite_exec db sql)))
                (die "sqlite_exec: " result))

             (sqlite_close db)
             (chown user group db_file)
             (chmod "600" db_file))

            ((< result 0)
             (die "directory in " db_path " not searchable by ephemera")))))

(defun send_day_wrapper ()
   (main send_day))

(defun send_recent_wrapper ()
   (main send_recent))

(defun send_oldest_wrapper ()
   (main send_oldest))

(defun send_month_wrapper ()
   (main send_month))

(defun send_one_wrapper ()
   (main send_one))

(defun main (func (generate))
   (if generate
      (send_headers 1)
      (send_headers))

   (println "<div id=\"main\">")
   (func)
   (print "</div>" nl "<div id=\"panel\">" nl)
   (send_panel)
   (print "</div>" nl "</body>" nl "</html>" nl))

(defun send_panel ()
   (println "<h1>"
            (if (not title_image)
               title
               (concat "<img src=\"" title_image "\" alt=\"" title "\" />"))
            "</h1>")

   (when before
      (print before))

   (print "<div class=\"center\">" nl
          "<h4>Navigation</h4>" nl
          "<p>" nl
          "<a href=\""

            (if static_main
               (cadr static_main)
               (concat path name))

          "\">Recent Entries</a><br/>" nl
          "<a href=\"" path name "?request=send_oldest\">Oldest Entries</a><br/>" nl

          "<a href=\"" (if static_main
                          (cadddr static_main)
                          (concat path name "?request=send_rss")) "\">RSS Feed</a>" nl
          "</p>" nl
          "</div>" nl

          "<div id=\"search\">" nl
          "<form action=\"" path name "\" method=\"post\" >" nl
          "<label for=\"key\">Search Entries:</label><br/>" nl
          "<input id=\"searchtext\" type=\"text\" name=\"key\" value=\"\" />" nl
          "<input type=\"hidden\" name=\"request\" value=\"send_search\" />" nl
          "</form>" nl
          "</div>" nl)

   (print (get_calendar (lookup data "year") (lookup data "mon")))

   (when after
      (print after)))

(let ((result ()))

   (defun send_rss ((static))
      (sqlite_bind rss_sql 1 (stringify rss_page_size))

      (print (if static "" (concat "Content-Type: text/xml" nl nl))
             "<?xml version=\"1.0\" encoding=\"utf-8\"?>" nl
             "<rss version=\"0.91\">" nl
             "<channel>" nl
             "<title>" (escape_markup title) "</title>" nl
             "<link>http://" host path name "</link>" nl
             "<description>" (remove_markup rss_description) "</description>" nl)

      (while (sqlite_step rss_sql)
         (setq result (sqlite_row rss_sql))

         (print "<item>" nl
                "<title>" (escape_markup (car result)) "</title>" nl
                "<link>http://" host path name "?request=send_one&amp;id=" (form_encode (cadr result)) "</link>" nl
                "<description>" (chomp (remove_markup (substring (caddr result) 0 160))) "...</description>" nl
                "</item>" nl))

      (sqlite_reset rss_sql)
      (print "</channel>" nl "</rss>" nl)))

(let ((local ())
      (dom ())
      (mday 0)
      (t 0)
      (t2 0)
      (result (stack))
      (mnth "")
      (stored (table))
      (prev_year 0)
      (next_year 0)
      (prev_mon 0)
      (next_mon 0)
      (first_day 0)
      (last_day 0)
      (first_sunday 0)
      (last_saturday 0))

   (defun get_calendar (year mon)
      (catch

         ; Determine the year and month.

         (when year (setq year (digitize year)))
         (when mon (setq mon (digitize mon)))
         (setq local (localtime (time)))

         (cond ((and (not year) (not mon))
                (setq year (car local))
                (setq mon (cadr local)))

               ((and (not year) mon)
                (setq year (car local)))

               ((and year (not mon))
                (setq mon (cadr local))))

         (when (setq t (lookup stored (stringify year mon)))
            (throw t))

         (when (or (< year 1970) (> year 10000) (< mon 1) (> mon 12))
            (throw ""))

         (clear result (used result))

         (setq mnth (month mon))

         ; Find first day of month.

         (setq first_day (date2days year mon 1))

         ; Find last day of month.

         (if (eq 12 mon)
            (setq last_day (date2days (+ 1 year) 1 1))
            (setq last_day (date2days year (+ 1 mon) 1)))

         (dec last_day)

         ; Find first Sunday of calendar.  May be part of previous month.

         (setq first_sunday first_day)

         (while (car (weekday first_sunday))
            (dec first_sunday))

         ; Find last Saturday of calendar.  May be last day of month or in
         ; next month.

         (setq last_saturday last_day)

         (while (not (eq 6 (car (weekday last_saturday))))
            (inc last_saturday))

         (if (not (eq mon 1))
            (progn
               (setq prev_year year)
               (setq prev_mon (- mon 1)))

            (setq prev_year (- year 1))
            (setq prev_mon 12))

         (if (not (eq mon 12))
            (progn
               (setq next_mon (+ mon 1))
               (setq next_year year))

            (setq next_year (+ year 1))
            (setq next_mon 1))

         (push result (concat "<div id=\"caldiv\">" nl))
         (push result (concat "<table id=\"cal_title\">" nl))

         (push result (stringify "<tr><td id=\"cal_title_left\">"
            (if (> prev_year 1969)
               (stringify "<a href=\"" path name "?request=send_month"
                                                 "&amp;time=" (date2time prev_year prev_mon 1)
                                                 "&amp;year=" prev_year "&amp;mon=" prev_mon "\">&lt;&lt;&lt;</a></td>")
               "&lt;")

            "<td id=\"cal_title_center\"><a href=\"" path name "?request=send_month"
                                                     "&amp;time=" (date2time year mon 1)
                                                     "&amp;year=" year "&amp;mon=" mon "\">" mnth " " year "</a></td>"

            "<td id=\"cal_title_right\">"
            "<a href=\"" path name "?request=send_month"
                                   "&amp;time=" (date2time next_year next_mon 1)
                                   "&amp;year=" next_year "&amp;mon=" next_mon "\">&gt;&gt;&gt;</a></td></tr>"))

         (push result (concat "</table>" nl
                "<table id=\"calendar\">" nl
                "<thead><tr><td>Sun</td><td>Mon</td><td>Tue</td><td>Wed</td>" nl
                "<td>Thu</td><td>Fri</td><td>Sat</td></tr></thead>" nl
                "<tr>"))

         (setq dom (days2date first_day))
         (setq year (car dom))
         (setq mon (cadr dom))
         (setq mday (caddr dom))
         (setq t (digitize (date2time year mon mday)))

         (for (day first_sunday last_saturday)
            (push result "<td>")

            (when (and (>= day first_day) (<= day last_day))
               (push result (stringify "<a href=\"" path name "?request=send_day&amp;time=" (unsigned t)
                  "&amp;year=" year "&amp;mon=" mon "\">" mday "</a>"))

               (inc mday)
               (inc t 86400))

            (push result "</td>")

            (when (and (< day last_saturday)
                       (eq 6 (car (weekday day))))
               (push result (concat "</tr>" nl "<tr>"))))

         (push result (concat "</tr>" nl "</table>" nl "</div>"))
         (hash stored (stringify year mon) (concat (flatten result))))))

(let ((result ()))

   (defun print_each (sql result count)
      (do
         (setq result (sqlite_row sql))
         (inc count)

         (print "<div class=\"article\">" nl
                "<!-- " (car (cdddr result)) " -->" nl)

         (when permalink
            (print "<div class=\"permalink\">" nl
                   "<p><a href=\"" path name "?request=send_one&amp;id="
                     (form_encode (car (cdddr result))) "\">"
                     "permalink</a></p>" nl
                     "</div>" nl))

         (print "<div class=\"date\"><p>"
                  (car result)
                  "</p></div>" nl

                  "<div class=\"internal\">" nl
                  "<h3>" (cadr result) "</h3>" nl
                  (caddr result) nl
                  "</div>" nl
                  "</div>" nl)

         (sqlite_step sql))

      (sqlite_reset sql)
      count))

(defun print_nav (request old_count count (tmp))
   (when permalink
      (print "<div class=\"pager\">" nl "<p>" nl)

      (when old_count
         (when (< (setq tmp (- old_count page_size)) 0)
            (setq tmp 0))

         (println "<a href=\"" path name "?request=" request
                  "&amp;index=" (stringify tmp) "\">previous</a>&nbsp;&nbsp;"))

      (when (and count (not (% count page_size)))
         (println "<a href=\"" path name "?request=" request
                  "&amp;index=" (stringify count) "\">next</a>"))

      (print "</p>" nl "</div>" nl)))

(let ((result ()))

   (defun print_results (title sql request count)
      (print"<div class=\"comtitle\">" nl
            "<h2>Result Set: " title "</h2>" nl
            "</div>" nl)

      (setq result (sqlite_step sql))

      (if result
          (print_nav request count (print_each sql result count))

          (sqlite_reset sql)
          (println "<div class=\"pager\"><p><span class=\"bold\">No " (if count "more " " ")
                   "entries in this result set.</span></p></div>")

          (when count
             (print_nav request count 0)))))

(defun send_search_wrapper ()
   (if (lookup data "key")
      (main send_search)
      (main send_recent)))

(setq time_rx (regcomp "^[0-9]+$"))
(setq blank_rx (regcomp (concat "[\b\t]*" (char 10) (char 10))))
(setq term_rx (regcomp (concat (char 13) (char 10))))

(setq system_print print)
(setq system_println println)
(setq system_newline newline)

(defun send_search ()
   (extend 'count (digitize (or (lookup data "index") "0")))

   ; SQLite performance degrades dramatically with a too large value in an
   ; OFFSET parameter.  Users are not likely to page back 5000 items
   ; manually, but a bot might.  We stop it from placing too much load on
   ; the host system.

   (if (> count 5000)
      (print "<div class=\"comtitle\">" nl
             "<h2>Result Set Limit Reached</h2>" nl
             "</div>" nl
             "<div class=\"pager\">" nl
             "<p>Only the first 5000 search results are returned.</p>" nl
             "</div>" nl)

      (extend 't (lookup data "key"))

      ; If, after escaping, the search key is empty, then don't add the
      ; % characters, or we will have a search key which matches every
      ; article.  This can happen if the user enters a key containing
      ; only HTML-significant characters.  After they are scrubbed the
      ; key will be empty.

      (when (extend 'nd (escape_like t))
         (setq nd (concat "%" nd "%")))

      ; Note it is not necessary to escape single quotes when using
      ; sqlite_bind.  All bound text is interpreted literally.  No SQL
      ; in query can be executed, rendering this data free from SQL
      ; injection attacks.

      (sqlite_bind search_sql 1 nd)
      (sqlite_bind search_sql 2 string_page_size)
      (sqlite_bind search_sql 3 (stringify count))

      (print_results (concat "Entries Containing: " (sanitize_html t))
                     search_sql
                     (concat "send_search&amp;key=" (form_encode t))
                     count)))

(let ((last_time 0) (last_nd 0) (last_response "") (cache (stack)))

   (let ((cache_print (lambda ((args)) (push cache (concat args))))
         (cache_println (lambda ((args)) (push cache (concat args nl))))
         (cache_newline (lambda () (push cache nl))))

      (defun send_one ()
         (extend 'nd (lookup data "id"))

         (if (and last_response (eq nd last_nd)
                 (< (timediff (time) last_time) 10))
            (print last_response)

            (setq last_time (time))
            (setq last_nd nd)

            (setq print cache_print)
            (setq println cache_println)
            (setq newline cache_newline)

            (sqlite_bind one_sql 1 nd)

            (protect
               (dynamic_let (permalink 0)
                  (print_results "Permalink"
                                 one_sql
                                 (concat "send_one&amp;id=" nd)
                                 0))

               (setq print system_print)
               (setq println system_println)
               (setq newline system_newline)

               (print (setq last_response (concat (flatten cache))))
               (clear cache (used cache)))))))

(let ((cache (stack)) (last_count 0) (last_time 0) (last_t 0) (last_response ""))

   (let ((cache_print (lambda ((args)) (push cache (concat args))))
         (cache_println (lambda ((args)) (push cache (concat args nl))))
         (cache_newline (lambda () (push cache nl))))

      (defun send_month ()
         (extend 'count (digitize (or (lookup data "index") "0")))
         (unless (match time_rx (extend 't (lookup data "time")))
            (setq t "-1"))

         (if (and last_response (eq t last_t) (eq count last_count)
                  (< (timediff (time) last_time) 10))
            (print last_response)

            (setq last_time (time))
            (setq last_count count)
            (setq last_t t)

            (setq print cache_print)
            (setq println cache_println)
            (setq newline cache_newline)

            (extend 'nd (localtime t))
            (extend 'mnth (stringify "Entries Created In " (month (cadr nd)) " " (car nd)))

            (if (eq (cadr nd) 12)
               (setq nd (date2time (+ 1 (car nd)) 1 1))
               (setq nd (date2time (car nd) (+ 1 (cadr nd)) 1)))

            (sqlite_bind month_sql 1 t)
            (sqlite_bind month_sql 2 nd)
            (sqlite_bind month_sql 3 string_page_size)
            (sqlite_bind month_sql 4 (stringify count))

            (protect
               (print_results mnth
                              month_sql
                              (concat "send_month&amp;time=" t "&amp;year=" (or (lookup data "year") "0")
                                      "&amp;mon=" (or (lookup data "mon") "0"))
                              count)

               (setq print system_print)
               (setq println system_println)
               (setq newline system_newline)

               (print (setq last_response (concat (flatten cache))))
               (clear cache (used cache)))))))

(let ((cache (stack)) (last_count 0) (last_time 0) (last_response ""))

   (let ((cache_print (lambda ((args)) (push cache (concat args))))
         (cache_println (lambda ((args)) (push cache (concat args nl))))
         (cache_newline (lambda () (push cache nl))))

      (defun send_oldest ()
         (extend 'count (digitize (or (lookup data "index") "0")))

         (if (> count 5000)
            (print "<div class=\"comtitle\">" nl
                   "<h2>Offset Limit Reached</h2>" nl
                   "</div>" nl
                   "<div class=\"pager\">" nl
                   "<p>Use the calendar to browse further forward in time.</p>" nl
                   "</div>" nl)

            (if (and last_response (eq count last_count)
                     (< (timediff (time) last_time) 10))
               (print last_response)

               (setq last_time (time))
               (setq last_count count)

               (setq print cache_print)
               (setq println cache_println)
               (setq newline cache_newline)

               (sqlite_bind oldest_sql 1 string_page_size)
               (sqlite_bind oldest_sql 2 (stringify count))

               (protect
                  (print_results "Oldest Entries"
                                 oldest_sql
                                 "send_oldest"
                                 count)

                  (setq print system_print)
                  (setq println system_println)
                  (setq newline system_newline)

                  (print (setq last_response (concat (flatten cache))))
                  (clear cache (used cache))))))))

(let ((cache (stack)) (last_count 0) (last_time 0) (last_response ""))

   (let ((cache_print (lambda ((args)) (push cache (concat args))))
         (cache_println (lambda ((args)) (push cache (concat args nl))))
         (cache_newline (lambda () (push cache nl))))

      (defun send_recent ()
         (extend 'count (digitize (or (lookup data "index") "0")))

         ; SQLite performance degrades dramatically with a too large value
         ; in an OFFSET parameter.  Users are not likely to page back 5000
         ; articles manually, but a bot might.  We stop it from placing too
         ; much load on the host system.

         (if (> count 5000)
            (print "<div class=\"comtitle\">" nl
                   "<h2>Offset Limit Reached</h2>" nl
                   "</div>" nl
                   "<div class=\"pager\">" nl
                   "<p>Use the calendar to browse further back in time.</p>" nl
                   "</div>" nl)

            (if (and last_response (eq count last_count)
                     (< (timediff (time) last_time) 10))
               (print last_response)

               (setq last_time (time))
               (setq last_count count)

               (setq print cache_print)
               (setq println cache_println)
               (setq newline cache_newline)

               (sqlite_bind recent_sql 1 string_page_size)
               (sqlite_bind recent_sql 2 (stringify count))

               (protect
                  (print_results "Recent Entries"
                                 recent_sql
                                 "send_recent"
                                 count)

                  (setq print system_print)
                  (setq println system_println)
                  (setq newline system_newline)

                  (print (setq last_response (concat (flatten cache))))
                  (clear cache (used cache))))))))

(let ((cache (stack)) (last_count 0) (last_time 0) (last_t 0) (last_response ""))

   (let ((cache_print (lambda ((args)) (push cache (concat args))))
         (cache_println (lambda ((args)) (push cache (concat args nl))))
         (cache_newline (lambda () (push cache nl))))

      (defun send_day ()
         (extend 'count (digitize (or (lookup data "index") "0")))
         (unless (match time_rx (extend 't (lookup data "time")))
            (setq t "-1"))

         (if (and last_response (eq last_t t) (eq last_count count)
                  (< (timediff (time) last_time) 10))
            (print last_response)

            (extend 'nd (localtime t))

            ; Detect non-zero hour values.  This means a transition to or from
            ; DST occurred during the month the day occurs in.  The code which
            ; generates the calendar is coded to be fast, by simply incrementing
            ; the value of the t attribute by 86400 for each day.  This avoids
            ; 28-31 calls to days2date, but it results in incorrect t values
            ; in those months in which DST begins or ends.  It's less expensive
            ; to compensate for these errors here.

            (cond ((eq 23 (cadddr nd))
                   (setq nd (localtime (setq t (stringify (+ (digitize t) 3600))))))

                  ((eq 1 (cadddr nd))
                   (setq nd (localtime (setq t (stringify (- (digitize t) 3600)))))))

            (extend 'mnth (stringify "Entries Created On " (caddr nd) " " (month (cadr nd)) " " (car nd)))
            (setq nd (date2days (car nd) (cadr nd) (caddr nd)))
            (setq nd (days2date (+ nd 1)))
            (setq nd (date2time (car nd) (cadr nd) (caddr nd)))

            (setq last_count count)
            (setq last_time (time))
            (setq last_t t)

            (setq print cache_print)
            (setq println cache_println)
            (setq newline cache_newline)

            (sqlite_bind day_sql 1 t)
            (sqlite_bind day_sql 2 nd)
            (sqlite_bind day_sql 3 string_page_size)
            (sqlite_bind day_sql 4 (stringify count))

            (protect
               (print_results mnth
                              day_sql
                              (concat "send_day&amp;time=" t "&amp;year=" (or (lookup data "year") "0")
                                      "&amp;mon=" (or (lookup data "mon") "0"))
                              count)

              (setq print system_print)
              (setq println system_println)
              (setq newline system_newline)

              (print (setq last_response (concat (flatten cache))))
              (clear cache (used cache)))))))

(let ((func 0))

   (defun service_request ()
      (get_data)

      (if (setq func (lookup requests (or (lookup data "request") "")))
         (func)
         (main send_recent))))

; Establish request handlers.

(setq requests (table))

(hash requests "send_oldest" send_oldest_wrapper)
(hash requests "send_recent" send_recent_wrapper)
(hash requests "send_day" send_day_wrapper)
(hash requests "send_month" send_month_wrapper)

(hash requests "send_one" send_one_wrapper)
(hash requests "send_search" send_search_wrapper)
(hash requests "send_rss" send_rss)

; ------------------------------------------------------------------------

; Server Functions.

; ------------------------------------------------------------------------

; Redefine "die".

(defun die ((args))
   (syslog 'CRITICAL (concat args))
   (exit 1))

(when (cadr (geteuid))
   (die "ephemera.munger must start as root."))

; pid file directory.

(setq piddir "/var/run/ephemera")

; If necessary, make the pid file directory.

(let ((tmp 0))
   (when (and (not (exists piddir))
              (stringp (setq tmp (mkdir piddir))))
      (die "could not make " piddir " directory: " tmp)))

; Start listening.

(when (stringp (setq result (listen port interface)))
   (die "listen: " result))

; Allow zombies, so master can know when slaves expire.

(zombies)

; Detach ourselves from terminal.

(daemonize "ephemera")

; Alist mapping server number to child pid, total number of running slaves,
; highest server number allocated, list of reclaimed server numbers
; from dead slaves, and current number of idle slaves.

(setq pids ())
(setq running 0)
(setq nextnum num_servers)
(setq reclaimed ())
(setq idle 0)

; Create busymap so slaves can communicate their status to master.  Must
; be created before we fork any slaves.

(let ((tmp 0))
   (when (stringp (setq tmp (busymap max_servers)))
      (die "could not create busymap: " tmp)))

; Function to fork server children.

(defun fork_server ((pid))
   (if (< (setq pid (fork)) 0)
      (die "couldn't fork child."))
      pid)

; Function to find the server number from a pid in the pids alist.

(defun find_number (pid (tmp))
   (setq tmp pids)

   (while (and tmp (not (eq pid (cadr (car tmp)))))
      (setq tmp (cdr tmp)))

   (if tmp
      (caar tmp)
      0))

; Function to reap zombie slaves.  We update alist of server numbers and
; pids, number of running slaves, number of idle slaves, and add server
; numbers to the reclaimed list.  We also remove the now-stale pid file for
; the slave.

(defun reap_zombies ((tmp))
   (while (> (car (setq tmp (wait -1 1))) 0)

      (when (setq result (find_number (car tmp)))
         (unlink (stringify piddir "/slave." result))
         (notbusy (- result 1))

         (dec running)
         (dec idle)
         (setq reclaimed (cons result reclaimed))
         (setq pids (alist_remove result pids)))))

; Function to count idle slaves.

(defun count_idle ((tmp))
   (reap_zombies)

   (setq tmp pids)
   (setq idle 0)

   (while tmp
      (inc idle (not (busyp (- (caar tmp) 1))))
      (setq tmp (cdr tmp))))

; Function to kill a single idle slave, if necessary.  A race condition
; exists between the call of count_idle and this function.  More or less
; slaves may be idle now than were counted.  If there are more idle, we'll
; kill another during a future invocation, if it's still idle then.  If
; there are less idle, then we will kill one more than we should.  That
; will be corrected when fork_more is invoked.

(defun kill_excess ((tmp))
   (count_idle)

   (catch
      (when (> idle num_servers)
         (for (n 1 nextnum)

            ; Test to see if the slave is not busy and it actually exists
            ; before doing anything.  Slaves which have died will have
            ; created holes in the busymap.  Only those on the pids alist
            ; are really alive.

            (and (setq tmp (alist_lookup n pids))
                 (not (busyp (- n 1)))
                 (kill (car tmp) 30) ; SIGUSR1
                 (throw 0))))))

; Function to fork slaves as necessary.

(defun fork_more ((pid))
   (count_idle)

   (while (and (< running max_servers) (< idle num_servers)
               (or reclaimed (< nextnum (- max_servers 1))))

      (if (setq pid (fork_server))
         (progn
            (inc running)
            (inc idle)

            (if (not reclaimed)
               (setq pids (alist_replace (inc nextnum) pids (list pid)))
               (setq pids (alist_replace (car reclaimed) pids (list pid)))
               (setq reclaimed (cdr reclaimed))))

         ; Child sets itself notbusy in busymap, and throws itself out of
         ; the toplevel loop of this function's caller.

         (setq result (if reclaimed (car reclaimed) (inc nextnum)))
         (notbusy (- result 1))
         (throw 0))))

; Master process creates database file if it does not already exist.

(create_db)
(open_db)
; Regenerate static main page and rss feed.

(unlink (car static_main))
(unlink (caddr static_main))

(setq rss_sql (sqlite_prepare db
   "SELECT Title,Id,Body FROM Articles ORDER BY Time DESC LIMIT ?"))

(setq recent_sql (sqlite_prepare db
   "SELECT Date,Title,Body,Id FROM Articles ORDER BY Time DESC LIMIT ?001 OFFSET ?002"))

(with_output_file (car static_main)
   (main send_recent 1))

(chown user group (car static_main))
(chmod "440" (car static_main))

(with_output_file (caddr static_main)
   (send_rss 1))

(sqlite_finalize rss_sql)
(sqlite_finalize recent_sql)
(sqlite_close db)

(chown user group (caddr static_main))
(chmod "440" (caddr static_main))

; Fork-off initial num_servers slaves.  Assigns 0 to result in parent, and
; server number to result in child.  The server number is used to specify a
; slave's entry in the busymap.

(let ((pid 0))
   (setq result

      (catch
         (for (n 1 num_servers)

            (if (not (setq pid (fork_server)))
               (throw n)

               (setq pids (alist_replace n pids (list pid)))
               (notbusy (- n 1))))

         0)))

; Parent stops here to becomes master server.  Children continue on to
; become slaves.

(let ((flip 0))

   (unless result

      ; Master pid file.

      (with_output_file (join "/" piddir "master") (println (getpid)))

      ; Loops here forever as root, managing the number of idle servers.

      (catch
         (loop
            (sleep 1)

            (if (not (eq 4 (inc flip)))
               (fork_more)

               (setq flip 0)
               (kill_excess))))))

; Result is set to slave's server number.

(setq busy_idx (- result 1))

; Each slave must open its own connection to the database.

(open_db)

; We don't check the return value of any of the sqlite intrinsics because
; it speeds things up.  If an error condition is encountered, the slave
; will exit, sooner than later, and be restarted by the master server.
; The only downside, is that we don't get a log message telling us what
; happened, if something does go wrong.

(setq rss_sql (sqlite_prepare db "SELECT Title,Id,Body FROM Articles ORDER BY Time DESC LIMIT ?"))
(setq recent_sql (sqlite_prepare db "SELECT Date,Title,Body,Id FROM Articles ORDER BY Time DESC LIMIT ?001 OFFSET ?002"))
(setq oldest_sql (sqlite_prepare db "SELECT Date,Title,Body,Id FROM Articles ORDER BY Time LIMIT ?001 OFFSET ?002"))
(setq search_sql (sqlite_prepare db "SELECT Date,Title,Body,Id FROM Articles WHERE Title LIKE ?001 OR Body LIKE ?001 ESCAPE '\' ORDER BY Time DESC LIMIT ?002 OFFSET ?003"))

(setq one_sql (sqlite_prepare db "SELECT Date,Title,Body,Id FROM Articles WHERE Id = ?"))
(setq month_sql (sqlite_prepare db "SELECT Date,Title,Body,Id FROM Articles WHERE Time >= ?001 AND Time < ?002 ORDER BY Time DESC LIMIT ?003 OFFSET ?004"))
(setq day_sql (sqlite_prepare db "SELECT Date,Title,Body,Id FROM Articles WHERE Time >= ?001 AND Time < ?002 ORDER By Time DESC LIMIT ?003 OFFSET ?004"))

; Write slave pid file before we change user and lose access to piddir.

(with_output_file (stringify piddir "/slave." result) (println (getpid)))

; Become a member of the configured group.

(when (stringp (setq result (setgid group)))
   (syslog 'CRITICAL "Could not join group " group ": " result))

; Become a less-privileged user.  We must do this after writing our pid
; file, because we need to be root to gain access to /var/run.

(when (stringp (setuid user))
   (syslog 'CRITICAL (concat "could not change to user " user))
   (exit 1))

; main loop.

(setq body "")

(let ((header "") (len 0))

   (while (fixnump (setq err (accept)))
      (busy busy_idx)

      (unless (setq header (get_scgi_header))
         (resume 0)
         (resume 1)
         (notbusy busy_idx)
         (continue))

      (while header
         (set (intern (car header)) (cadr header))
         (setq header (cddr header)))

      (setq len (digitize CONTENT_LENGTH))

      (while len
         (setq body (concat body (getchars len)))
         (dec len (length body)))

      (protect
         (service_request)

         (resume 0)
         (resume 1)

         (setq header "")
         (setq body "")

         (notbusy busy_idx))))

; Slaves are designed to be killed by signals.  If we get here,
; accept generated an error.

(syslog 'CRITICAL err)
(quit)
