aboutsummaryrefslogtreecommitdiff
path: root/cgi-bin/nea.scm4
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2006-10-08 21:40:09 +0000
committerSergey Poznyakoff <gray@gnu.org.ua>2006-10-08 21:40:09 +0000
commit109cf4d84378cbfce6b157ac854383be2a9ea866 (patch)
tree9c1b4a25f39d3f7bf7a8ecf879b1b40014f4af5a /cgi-bin/nea.scm4
parentc4a4896b38006d9966ffd6112e27539ba0efeaca (diff)
downloadellinika-109cf4d84378cbfce6b157ac854383be2a9ea866.tar.gz
ellinika-109cf4d84378cbfce6b157ac854383be2a9ea866.tar.bz2
*** empty log message ***
git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@460 941c8c0f-9102-463b-b60b-cd22ce0e6858
Diffstat (limited to 'cgi-bin/nea.scm4')
-rw-r--r--cgi-bin/nea.scm4536
1 files changed, 536 insertions, 0 deletions
diff --git a/cgi-bin/nea.scm4 b/cgi-bin/nea.scm4
new file mode 100644
index 0000000..20e1803
--- /dev/null
+++ b/cgi-bin/nea.scm4
@@ -0,0 +1,536 @@
+;;;; News page for Ellinika
+;;;; Copyright (C) 2004, 2005, 2006 Sergey Poznyakoff
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program; if not, write to the Free Software
+;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+;;;;
+
+;;; Tailor this statement to your needs if necessary.
+(set! %load-path (cons "GUILE_SITE" %load-path))
+
+(use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user))
+ (gamma sql)
+ (gamma gettext)
+ (xmltools dict)
+ (ellinika xlat)
+ (ellinika cgi))
+
+ifelse(IFACE,[CGI],(cgi:init))
+
+(define tmpl (if (and monima-nea-template-file-name
+ (cgi:value "timestamp"))
+ monima-nea-template-file-name
+ nea-template-file-name))
+
+(ellinika-cgi-init tmpl)
+
+(define conn #f)
+(define article #f)
+(define accepted-lang (map
+ (lambda (s)
+ (cond
+ ((string-split s #\;) =>
+ (lambda (l)
+ (car l)))
+ (else
+ s)))
+ (string-split (or
+ (getenv "HTTP_ACCEPT_LANGUAGE")
+ "")
+ #\,)))
+
+(define nea-max-rows 20) ;; FIXME: Move to the config
+
+(define (permalink tag timestamp)
+ (display (string-append "<" tag " class=\"permalink\">"))
+ (display "<a href=\"")
+ (display (make-cgi-name cgi-script-name "timestamp" timestamp))
+ (display "\">[permanent link]</a>")
+ (display (string-append "</" tag ">")))
+
+(define (sql-error-handler err descr)
+ (format #t "<h1 class=\"error\">~A</h1>\n"
+ (_ "ΣΦΆΛΜΑ: σύνδεση με την βάση δεδομένων απέτυχε."))
+ (with-output-to-port
+ (current-error-port)
+ (lambda ()
+ (display err)
+ (display ": ")
+ (display descr))))
+
+(defmacro catch-sql (expr)
+ `(catch 'gsql-error
+ (lambda () ,expr)
+ (lambda (key err descr)
+ (sql-error-handler err descr))))
+
+(defmacro assert-article (. expr)
+ `(if article
+ (cond
+ ((null? article)
+ (format #t "<h1 class=\"error\">~A</h1>\n"
+ (_ "Κάμια καταχώρηση")))
+ (else
+ ,@expr))))
+
+(define (make-sql-list input-list)
+ (let loop ((str "")
+ (input-list input-list))
+ (if (null? input-list)
+ (string-append "(" str ")")
+ (loop (string-append str
+ (if (string-null? str) "'" ",'")
+ (car input-list) "'")
+ (cdr input-list)))))
+
+(define (get-sql-lang conn ident langlist)
+ (let ((res (map car (sql-query conn
+ (string-append
+ "SELECT lang "
+ "FROM newsart "
+ "WHERE ident=" ident " "
+ "AND lang in " (make-sql-list langlist))))))
+ (cond
+ ((null? res)
+ #f)
+ (else
+ (call-with-current-continuation
+ (lambda (return)
+ (for-each
+ (lambda (elt)
+ (if (member elt res)
+ (return elt)))
+ langlist)))))))
+
+(define (make-my-lang-list)
+ (map language-code (cons target-language
+ accepted-lang)))
+
+
+(define (collect-entries from fwd)
+ (let loop ((start from)
+ (result '()))
+ (cond
+ ((not fwd)
+ (set! start (- start nea-max-rows))
+ (if (< start 0)
+ (set! start 0))))
+ (call-with-current-continuation
+ (lambda (return)
+ (let ((tuples (sql-query
+ conn
+ (format #f
+ "SELECT date,ident FROM news ORDER BY 1 DESC LIMIT ~A,~A"
+ start nea-max-rows))))
+ (cond
+ ((null? tuples)
+ (cons start (if fwd (reverse result) result)))
+ (else
+ (let ((langlist (make-my-lang-list))
+ (rest (- nea-max-rows (length result)))
+ (ctr 0))
+ (for-each
+ (lambda (entry)
+ (let ((lang (get-sql-lang conn (list-ref entry 1) langlist)))
+ (set! ctr (1+ ctr))
+ (if lang
+ (let ((hdr (sql-query conn
+ (string-append
+ "SELECT header,lang "
+ "FROM newsart "
+ "WHERE ident=" (list-ref entry 1) " "
+ "AND lang='" lang "' "
+ "LIMIT 1"))))
+ (cond
+ (hdr
+ (set! result (cons
+ (cons (caar hdr) entry)
+ result))
+ (set! rest (1- rest))
+ (cond
+ ((= 0 rest)
+ (if fwd
+ (return (cons (+ ctr start) (reverse result)))
+ (return (cons (+ start (- nea-max-rows ctr))
+ result)))))))))))
+
+ (if fwd
+ tuples
+ (reverse tuples)))
+
+ (cond
+ ((and (not fwd) (= 0 start))
+ (cons start (if fwd (reverse result) result)))
+ (else
+ (if fwd
+ (set! start (+ ctr start)))
+ (loop start result)))))))))))
+
+(define (summary)
+ (catch-sql
+ (let* ((count (catch #t
+ (lambda ()
+ (string->number
+ (caar (sql-query conn "SELECT count(*) FROM news"))))
+ (lambda args
+ 0)))
+ (from (catch #t
+ (lambda ()
+ (let ((x (string->number (cgi:value "from"))))
+ (if (< x count)
+ x
+ 0)))
+ (lambda args
+ 0)))
+ (fwd (let ((dir (cgi:value "dir")))
+ (or (not dir)
+ (string=? dir "1"))))
+ (entries (collect-entries from fwd)))
+
+ (let ((start (car entries))
+ (result (cdr entries)))
+ (cond
+ ((null? result)
+ (display "<div align=\"center\">")
+ (display (_ "Κανένα νέα"))
+ (display "</div>"))
+ (else
+ (let ((num-entries (length result))
+ (begin (if fwd from start))
+ (end (if fwd start from))
+ (id (cgi:value "id")))
+
+ (cond
+ ((not (and (= from 0) (< num-entries nea-max-rows)))
+ (display "<p>")
+ (format #t (_ "Εγγραφείς ~A - ~A") begin end)
+ (display "</p>")))
+
+ (display "<table class=\"news-summary frame\">\n")
+ (let ((ctr 0)
+ (langlist (make-my-lang-list)))
+ (for-each
+ (lambda (entry)
+ (display "<tr class=\"")
+ (display (if (= (modulo ctr 2) 0) "even" "odd"))
+ (display "\">\n")
+ (set! ctr (1+ ctr))
+ (display "<td class=\"date\">")
+ (display (list-ref entry 1))
+ (display "</td>")
+ (display "<td class=\"subject")
+ (cond
+ ((and id (string=? (list-ref entry 2) id))
+ (display " current\">")
+ (display (list-ref entry 0)))
+ (else
+ (display "\"><a href=\"")
+ (display (make-cgi-name cgi-script-name
+ "id" (list-ref entry 2)
+ "from" (number->string begin)))
+ (display "\">")
+ (display (list-ref entry 0))
+ (display "</a>")))
+ (display "</td>")
+ (display "\n</tr>\n"))
+ result))
+ (display "</table>")
+
+ (display "<div class=\"menu-bar\" align=\"center\">")
+ (cond
+ ((> begin 0)
+ (display "<span class=\"menu-cell\"><a href=\"")
+ (display (apply make-cgi-name
+ cgi-script-name
+ "from" (number->string begin)
+ "dir" "0"
+ (if id
+ (list "id" id)
+ '())))
+ (display "\">")
+ (display (_ "Προηγούμενες"))
+ (display "</a></span>")))
+
+ (cond
+ ((< end count)
+ (display "<span class=\"menu-cell\"><a href=\"")
+ (display (apply make-cgi-name
+ cgi-script-name
+ "from" (number->string end)
+ "dir" "1"
+ (if id
+ (list "id" id)
+ '())))
+ (display "\">")
+ (display (_ "Ερχόμενες"))
+ (display "</a></span>")))
+ (display "</div>"))))))))
+
+(define (display-article-header item)
+ (display "<div id=\"news-header\">")
+ (format #t "<span class=\"itemdate\">~A</span>\n" (car item))
+ (display "<span class=\"itemsubject\">\n")
+ (display (list-ref item 2))
+ (display "</span>")
+ (if (not (cgi:value "timestamp"))
+ (permalink "span" (list-ref item 1)))
+ (display "</div><!-- news-header -->"))
+
+(define (display-article-text item . rest)
+ (let ((class (and (not (null? rest)) (car rest))))
+ (cond
+ (class
+ (display "\n<div class=\"")
+ (display class)
+ (display "\">\n")
+ (display (list-ref item 3))
+ (display "</div>\n"))
+ (else
+ (display (list-ref item 3))))))
+
+(define (main)
+ (catch-sql
+ (assert-article
+ (display-article-header article)
+ (display-article-text article "itemtext"))))
+
+(define (title)
+ (if article
+ (display (if (null? article)
+ (string-append
+ "<h1 class=\"error\">"
+ (_ "Κάμια καταχώρηση")
+ "</h1>")
+ (list-ref article 2)))))
+
+
+(define (nea-html)
+ (let ((explist (list (cons "@@main@@" main)
+ (cons "@@summary@@" summary)
+ (cons "@@title@@" title)
+ (cons "@@article-text@@"
+ (lambda ()
+ (catch-sql
+ (assert-article
+ (display-article-text article)))))
+ (cons "@@article-date@@"
+ (lambda ()
+ (catch-sql
+ (assert-article
+ (display (car article))))))
+ (cons "@@article-header@@"
+ (lambda ()
+ (catch-sql
+ (assert-article
+ (display (list-ref article 2))))))
+ (cons "@@full-header@@"
+ (lambda ()
+ (catch-sql
+ (assert-article
+ (display-article-header
+ article)))))
+ (cons "@@args@@"
+ (lambda ()
+ (for-each
+ (lambda (name)
+ (cond
+ ((string=? name "LANG"))
+ (else
+ (let ((v (cgi:value name)))
+ (cond ((and v (not (string-null? v)))
+ (display "&amp;")
+ (display name)
+ (display "=")
+ (display v)))))))
+ (cgi:names)))))))
+
+ (do ((line (read-line) (read-line)))
+ ((eof-object? line) #f)
+ (expand-template explist line)
+ (newline))))
+
+(define (nea-rss-header)
+ (display "<?xml version=\"1.0\"?>\n")
+ (display "<rss version=\"2.0\">
+ <channel>
+ <title>Τα νέα</title>
+ <description>Τα νέα</description>
+ <link>http://ellinika.gnu.org.ua</link>")
+ (format #t "<language>~A</language>" (language-code target-language))
+ (display "
+ <generator>EllinikaNea</generator>
+ <copyright>2006 Sergey Poznyakoff</copyright>
+ <managingEditor>gray@gnu.org.ua</managingEditor>
+ <docs>http://blogs.law.harvard.edu/tech/rss</docs>
+"))
+
+(define (nea-rss-footer)
+ (display " </channel>
+</rss>"))
+
+(define (nea-sql-connect)
+ (let ((conn (sql-connect
+ sql-iface sql-host sql-port sql-database
+ sql-username sql-password)))
+ (sql-query conn "SET NAMES utf8")
+ conn))
+
+(define (nea-rss)
+ (nea-rss-header)
+ (catch 'gsql-error
+ (lambda ()
+ (let ((conn (nea-sql-connect)))
+ (for-each
+ (lambda (tuple)
+ (display "<item>\n")
+ (display "<pubDate>")
+ (display (list-ref tuple 0))
+ (display "</pubDate>\n")
+ (display "<title>")
+ (let ((title (sql-query conn
+ (string-append
+ "SELECT header "
+ "FROM newsart "
+ "WHERE ident=" (list-ref tuple 2) " "
+ "AND lang='"
+ (get-sql-lang conn
+ (list-ref tuple 2)
+ (make-my-lang-list))
+ "' "
+ "LIMIT 1"))))
+ (display (if (not (null? title))
+ (caar title)
+ (list-ref tuple 0))))
+ (display "</title>\n")
+ (display "<link>")
+ (display (string-append
+ (string-downcase cgi-server-protocol-name)
+ "://"
+ cgi-server-hostname
+ "/"
+ (make-cgi-name cgi-script-name
+ "timestamp" (list-ref tuple 1))))
+ (display "</link>\n")
+ (display "</item>\n"))
+ (sql-query
+ conn
+ (string-append
+ "SELECT date,unix_timestamp(date),ident "
+ "FROM news "
+ "ORDER BY 1 DESC LIMIT 10")))))
+ (lambda (key err descr)
+ (sql-error-handler err descr)))
+ (nea-rss-footer))
+
+
+(define (get-article-by-timestamp ts)
+ (let ((tuples (sql-query
+ conn
+ "SELECT date,unix_timestamp(date),ident FROM news WHERE unix_timestamp(date)=" ts)))
+ (cond
+ (tuples
+ (let* ((res (car tuples))
+ (lang (get-sql-lang conn (list-ref res 2) (make-my-lang-list)))
+ (art (sql-query conn
+ (string-append
+ "SELECT header,text,lang "
+ "FROM newsart "
+ "WHERE ident=" (list-ref res 2) " "
+ "AND lang='" lang "' "
+ "LIMIT 1"))))
+ (append
+ (list (list-ref res 0)
+ (list-ref res 1))
+ (car art)))))))
+
+
+;;; Main
+
+(cond
+ ((cgi:value "rss")
+ ifelse(IFACE,[CGI],
+ (display ["Content-type: text/xml; charset=utf-8\r\n\r\n"]),
+ (request-rec:set-content-type! Request ["text/xml; charset=UTF-8"]))
+ (nea-rss))
+ (else
+ (catch 'gsql-error
+ (lambda ()
+ ifelse(IFACE,[CGI],dnl
+ (display ["Content-type: text/html; charset=utf-8\r\n\r\n"]))
+ (set! conn (nea-sql-connect))
+ (cond
+ ((or (cgi:value "timestamp") (cgi:value "id"))
+ (let ((tuples (sql-query
+ conn
+ (string-append
+ "SELECT date,unix_timestamp(date),ident "
+ "FROM news "
+ "WHERE "
+ (cond
+ ((cgi:value "timestamp") =>
+ (lambda (ts)
+ (string-append "unix_timestamp(date)=" ts)))
+ ((cgi:value "id") =>
+ (lambda (id)
+ (string-append "ident=" id))))))))
+
+ (if (not (null? tuples))
+ (let* ((res (car tuples))
+ (lang (get-sql-lang conn
+ (list-ref res 2)
+ (make-my-lang-list)))
+ (art (sql-query
+ conn
+ (string-append
+ "SELECT header,text,lang "
+ "FROM newsart "
+ "WHERE ident=" (list-ref res 2) " "
+ "AND lang='" lang "' "
+ "LIMIT 1"))))
+ (set! article (append
+ (list (list-ref res 0)
+ (list-ref res 1))
+ (car art))))))))
+
+ (with-input-from-file
+ (template-file target-language tmpl)
+ nea-html)
+
+ (sql-connect-close conn))
+
+ (lambda (key err descr)
+ (with-input-from-file
+ (template-file target-language tmpl)
+ (lambda ()
+ (let ((explist
+ (list (cons "@@main@@"
+ (lambda ()
+ (sql-error-handler err descr)))
+ (cons "@@article-text@@"
+ (lambda ()
+ (sql-error-handler err descr)))
+ (cons "@@summary@@" (lambda () #f))
+ (cons "@@title@@" (lambda () #f))
+ (cons "@@article-date@@" (lambda () #f))
+ (cons "@@article-header@@" (lambda () #f))
+ (cons "@@full-header@@" (lambda () #f)))))
+ (do ((line (read-line) (read-line)))
+ ((eof-object? line) #f)
+ (expand-template explist line)
+ (newline)))))))))
+
+;;;; Local variables:
+;;;; mode: Scheme
+;;;; buffer-file-coding-system: utf-8
+;;;; End:

Return to:

Send suggestions and report system problems to the System administrator.