aboutsummaryrefslogtreecommitdiff
path: root/cgi-bin/nea.cgi.in
diff options
context:
space:
mode:
Diffstat (limited to 'cgi-bin/nea.cgi.in')
-rw-r--r--cgi-bin/nea.cgi.in328
1 files changed, 249 insertions, 79 deletions
diff --git a/cgi-bin/nea.cgi.in b/cgi-bin/nea.cgi.in
index ca609ab..ed8c753 100644
--- a/cgi-bin/nea.cgi.in
+++ b/cgi-bin/nea.cgi.in
@@ -2,7 +2,7 @@
=AUTOGENERATED=
!#
;;;; News page for Ellinika
-;;;; Copyright (C) 2004, 2005 Sergey Poznyakoff
+;;;; 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
@@ -39,6 +39,16 @@
(define conn #f)
(define article #f)
+(define accepted-lang (map
+ (lambda (s)
+ (cond
+ ((string-split s #\;) =>
+ (lambda (l)
+ (car l)))
+ (else
+ s)))
+ (string-split (getenv "HTTP_ACCEPT_LANGUAGE") #\,)))
+
(define (permalink tag timestamp)
(display (string-append "<" tag " class=\"permalink\">"))
@@ -63,17 +73,51 @@
(lambda (key err descr)
(sql-error-handler err descr))))
-(defmacro assert-article (expr)
+(defmacro assert-article (. expr)
`(if article
- (if (null? article)
- (format #t "<h1 class=\"error\">~A</h1>\n"
- (_ "Κάμια καταχώρηση"))
- ,expr)))
-
+ (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 (summary)
(catch-sql
(let ((result (sql-query
- conn "SELECT date,header,ident FROM news ORDER BY date")))
+ conn "SELECT date,ident FROM news ORDER BY 1 DESC")))
(cond
((null? result)
(display "<div align=\"center\">")
@@ -81,22 +125,33 @@
(display "</div>"))
(else
(display "<table class=\"news-summary\">\n")
- (let ((ctr 0))
+ (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 0))
- (display "</td>")
- (display "<td class=\"subject\"><a href=\"")
- (display (make-cgi-name nea-cgi-path "id" (list-ref entry 2)))
- (display "\">")
- (display (list-ref entry 1))
- (display "</a></td>")
- (display "\n</tr>\n"))
+ (let* ((lang (get-sql-lang conn (list-ref entry 1) langlist))
+ (hdr (sql-query conn
+ (string-append
+ "SELECT header,lang "
+ "FROM newsart "
+ "WHERE ident=" (list-ref entry 1) " "
+ "AND lang='" lang "' "
+ "LIMIT 1"))))
+ (cond
+ (hdr
+ (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 0))
+ (display "</td>")
+ (display "<td class=\"subject\"><a href=\"")
+ (display (make-cgi-name nea-cgi-path "id" (list-ref entry 1)))
+ (display "\">")
+ (display (list-ref (car hdr) 0))
+ (display "</a></td>")
+ (display "\n</tr>\n")))))
result))
(display "</table>"))))))
@@ -121,15 +176,12 @@
(define (main)
(catch-sql
(assert-article
- (for-each
- (lambda (item)
- (display-article-header item)
+ (display-article-header article)
- (if (not (cgi:value "timestamp"))
- (permalink "span" (list-ref item 1)))
+ (if (not (cgi:value "timestamp"))
+ (permalink "span" (list-ref article 1)))
- (display-article-text item "itemtext"))
- article))))
+ (display-article-text article "itemtext"))))
(define (title)
(if article
@@ -138,7 +190,7 @@
"<h1 class=\"error\">"
(_ "Κάμια καταχώρηση")
"</h1>")
- (list-ref (car article) 2)))))
+ (list-ref article 2)))))
(define (nea-html)
@@ -149,76 +201,194 @@
(lambda ()
(catch-sql
(assert-article
- (display-article-text (car article))))))
+ (display-article-text article)))))
(cons "@@article-date@@"
(lambda ()
(catch-sql
(assert-article
- (display (caar article))))))
+ (display (car article))))))
(cons "@@article-header@@"
(lambda ()
(catch-sql
(assert-article
- (display (list-ref (car article) 2))))))
+ (display (list-ref article 2))))))
(cons "@@full-header@@"
(lambda ()
(catch-sql
(assert-article
(display-article-header
- (car article)))))))))
+ article))))))))
(do ((line (read-line) (read-line)))
((eof-object? line) #f)
(expand-template explist line)
(newline))))
-;;; Main
-(display "Content-type: text/html; charset=utf-8\r\n\r\n")
-
-(catch 'gsql-error
- (lambda ()
- (set! conn (sql-connect
- sql-iface sql-host sql-port sql-database
- sql-username sql-password))
-
- (if (or (cgi:value "timestamp") (cgi:value "id"))
- (set! article (sql-query conn
- (cond
- ((cgi:value "timestamp")
- (string-append
- "SELECT date,unix_timestamp(date),header,text FROM news WHERE unix_timestamp(date)="
- (cgi:value "timestamp")))
- ((cgi:value "id")
+(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 date,unix_timestamp(date),header,text FROM news WHERE ident="
- (cgi:value "id")))))))
-
- (with-input-from-file
- (template-file target-language tmpl)
- nea-html)
+ "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 nea-cgi-path "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))
- (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)))))))
+
+(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
+
+(debug-enable 'debug)
+(debug-enable 'backtrace)
+
+(cond
+ ((cgi:value "rss")
+ (display "Content-type: text/xml; charset=utf-8\r\n\r\n")
+ (nea-rss))
+ (else
+ (catch 'gsql-error
+ (lambda ()
+ (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))))))))
+ (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

Return to:

Send suggestions and report system problems to the System administrator.