#!/usr/local/bin/munger

; Copyright (c) 2009-2011 James Bailie.
; All rights reserved.
;
; Redistribution and use in source form, with or without modification, are
; 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 generates the static main page.  It is called by
; ephemera-add, ephemera-replace, and ephemera-delete.

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

(fatal)
(setq ephemera_version "2.9")

(load "/usr/local/etc/ephemera.config")
(setq db_file (join "/" db_path db_name))

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

; 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")))))

; Newline and carriage return.

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

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

(defun send_headers ()

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

   (print

      ; DOCTYPE document definition.

      "<!DOCTYPE html>" nl

      ; HTML header.

      "<html xmlns=\"http://www.w3.org/1999/xhtml\">" 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>"))

(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 (or (< year 1970) (> year 10000) (< mon 1) (> mon 12))
         (throw ""))

      (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))

      (print "<div id=\"caldiv\">" nl
             "<table id=\"cal_title\">" nl

             "<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>"

             "</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)
         (print "<td>")

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

            (inc mday)
            (inc t 86400))

         (print "</td>")

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

      (println "</tr>" nl "</table>" nl "</div>")))

(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=\"" (concat 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)

   (get_calendar "" "")

   (when after
      (print after)))

(let ((amp_rx (regcomp "&"))
      (apos_rx (regcomp "'"))
      (quot_rx (regcomp "\""))
      (lt_rx (regcomp "<"))
      (gt_rx (regcomp ">"))
      (tag_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))))

(let ((result ()))

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

      (print "<?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)))

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

(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

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

                "<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))
   (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 old_count count)
      (print"<div class=\"comtitle\">" nl
            "<h2>Result Set: " title "</h2>" nl
            "</div>" nl)

      (setq result (sqlite_step sql))

      (if result
          (print_nav request old_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 old_count
            (setq count 0)
            (print_nav request old_count count)))))

(defun send_recent ()
   (sqlite_bind recent_sql 1 (stringify page_size))
   (sqlite_bind recent_sql 2 "0")
   (print_results "Recent Entries" recent_sql "send_recent" 0 0))

(create_db)
(open_db)

; Regenerate static main page and rss feed.

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

(open_db)

(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))

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

(with_output_file (caddr static_main)
   (send_rss))

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

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