1 files changed, 536 insertions, 0 deletions

diff --git a/cgi-bin/nea.scm4 b/cgi-bin/nea.scm4
new file mode 100644
index 0000000..20e1803
--- /dev/null
+++ b/cgi-bin/nea.scm4
@@ -0,0 +1,536 @@
+;;;; 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.
+(set! %load-path (cons "GUILE_SITE" %load-path))
+
+(use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user))
+             (gamma sql)
+             (gamma gettext)
+             (xmltools dict)
+             (ellinika xlat)
+             (ellinika cgi))
+
+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 "<a href=\"")
+  (display (make-cgi-name cgi-script-name "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 (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 "<div align=\"center\">")
+         (display (_ "Κανένα νέα"))
+         (display "</div>"))
+        (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 "<p>")
+             (format #t (_ "Εγγραφείς ~A - ~A") begin end)
+             (display "</p>")))
+           
+           (display "<table class=\"news-summary frame\">\n")
+           (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 1))
+                (display "</td>")
+                (display "<td class=\"subject")
+                (cond
+                 ((and id (string=? (list-ref entry 2) id))
+                  (display " current\">")