;;;; 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 "" tag ">")))
(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 (list-ref entry 1))
(display " ")
(display "")
(display (list-ref entry 0)))
(else
(display "\">string begin)))
(display "\">")
(display (list-ref entry 0))
(display " ")))
(display " ")
(display "\n \n"))
result))
(display "
")
(display ""))))))))
(define (display-article-header item)
(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: