#! =GUILE_BINDIR=/guile -s
=AUTOGENERATED=
!#
;;;; 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.
;=GUILE_COMMENT=;(set! %load-path (cons "=GUILE_SITE=" %load-path))

(use-modules (www cgi)
	     (gamma sql)
	     (gamma gettext)
	     (xmltools dict)
	     (ellinika xlat)
	     (ellinika 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 (getenv "HTTP_ACCEPT_LANGUAGE") #\,)))


(define (permalink tag timestamp)
  (display (string-append "<" tag " class=\"permalink\">"))
  (display "<a href=\"")
  (display (make-cgi-name nea-cgi-path "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 (summary)
  (catch-sql
   (let ((result (sql-query
		  conn "SELECT date,ident FROM news ORDER BY 1 DESC")))
     (cond
      ((null? result)
       (display "<div align=\"center\">")
       (display (_ "Κανένα νέα"))
       (display "</div>"))
      (else
       (display "<table class=\"news-summary\">\n")
       (let ((ctr 0)
	     (langlist (make-my-lang-list)))
	 (for-each
	  (lambda (entry)
	    (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>"))))))

(define (display-article-header item)
  (format #t "<span class=\"itemdate\">~A</span>\n" (car item))
  (display "<span class=\"itemsubject\">\n")
  (display (list-ref item 2))
  (display "</span> "))

(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)
       
    (if (not (cgi:value "timestamp"))
	(permalink "span" (list-ref article 1)))
       
    (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))))))))
  
    (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 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))


(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
;;;; buffer-file-coding-system: utf-8
;;;; End: