diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2006-03-17 19:57:59 +0000 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2006-03-17 19:57:59 +0000 |
commit | 4633d7f905f174dd89442655ecab69a447b7bd8e (patch) | |
tree | d875be157117b856546d3a0024d721978f516c31 /cgi-bin | |
parent | db6e0e75a16670791ed6a6708bc4ec5815720d0a (diff) | |
download | ellinika-4633d7f905f174dd89442655ecab69a447b7bd8e.tar.gz ellinika-4633d7f905f174dd89442655ecab69a447b7bd8e.tar.bz2 |
Improve i18n support. Implement RSS generation.
git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@356 941c8c0f-9102-463b-b60b-cd22ce0e6858
Diffstat (limited to 'cgi-bin')
-rw-r--r-- | cgi-bin/nea.cgi.in | 328 |
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 |