;;;; News page for Ellinika ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2010 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 3 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, see . ;;;; ;;; 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)) (ice-9 rdelim) (gamma sql) (xmltools dict) (ellinika xlat) (ellinika cgi) (ellinika i18n)) 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 "[permanent link]") (display (string-append ""))) (define (sql-error-handler err descr) (format #t "

~A

\n" (_ "ΣΦΆΛΜΑ: σύνδεση με την βάση δεδομένων απέτυχε.")) (apply format (current-error-port) fmt fmtargs)) (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 "

~A

\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 "
") (display (_ "Κανένα νέα")) (display "
")) (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 "

") (format #t (_ "Εγγραφείς ~A - ~A") begin end) (display "

"))) (display "\n") (let ((ctr 0) (langlist (make-my-lang-list))) (for-each (lambda (entry) (display "\n") (set! ctr (1+ ctr)) (display "") (display "") (display "\n\n")) result)) (display "
") (display (list-ref entry 1)) (display "") (display (list-ref entry 0))) (else (display "\">string begin))) (display "\">") (display (list-ref entry 0)) (display ""))) (display "
") (display "
") (cond ((> begin 0) (display "string begin) "dir" "0" (if id (list "id" id) '()))) (display "\">") (display (_ "Προηγούμενες")) (display ""))) (cond ((< end count) (display "string end) "dir" "1" (if id (list "id" id) '()))) (display "\">") (display (_ "Ερχόμενες")) (display ""))) (display "
")))))))) (define (display-article-header item) (display "
") (format #t "~A\n" (car item)) (display "\n") (display (list-ref item 2)) (display "") (if (not (cgi:value "timestamp")) (permalink "span" (list-ref item 1))) (display "
")) (define (display-article-text item . rest) (let ((class (and (not (null? rest)) (car rest)))) (cond (class (display "\n
\n") (display (list-ref item 3)) (display "
\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 "

" (_ "Κάμια καταχώρηση") "

") (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 "&") (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 "\n") (display " Τα νέα Τα νέα http://ellinika.gnu.org.ua") (format #t "~A" (language-code target-language)) (display " EllinikaNea 2006 Sergey Poznyakoff gray@gnu.org.ua http://blogs.law.harvard.edu/tech/rss ")) (define (nea-rss-footer) (display " ")) (define (nea-sql-connect) (let ((conn (sql-open-connection ellinika-sql-connection))) (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 "\n") (display "") (display (list-ref tuple 0)) (display "\n") (display "") (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 "\n") (display "") (display (string-append (string-downcase cgi-server-protocol-name) "://" cgi-server-hostname "/" (make-cgi-name cgi-script-name "timestamp" (list-ref tuple 1)))) (display "\n") (display "\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-close-connection 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: