aboutsummaryrefslogtreecommitdiff
path: root/cgi-bin/nea.cgi.in
diff options
context:
space:
mode:
Diffstat (limited to 'cgi-bin/nea.cgi.in')
-rw-r--r--cgi-bin/nea.cgi.in534
1 files changed, 0 insertions, 534 deletions
diff --git a/cgi-bin/nea.cgi.in b/cgi-bin/nea.cgi.in
deleted file mode 100644
index b8eeae4..0000000
--- a/cgi-bin/nea.cgi.in
+++ /dev/null
@@ -1,534 +0,0 @@
1#! =GUILE_BINDIR=/guile -s
2=AUTOGENERATED=
3!#
4;;;; News page for Ellinika
5;;;; Copyright (C) 2004, 2005, 2006 Sergey Poznyakoff
6;;;;
7;;;; This program is free software; you can redistribute it and/or modify
8;;;; it under the terms of the GNU General Public License as published by
9;;;; the Free Software Foundation; either version 2 of the License, or
10;;;; (at your option) any later version.
11;;;;
12;;;; This program is distributed in the hope that it will be useful,
13;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;;; GNU General Public License for more details.
16;;;;
17;;;; You should have received a copy of the GNU General Public License
18;;;; along with this program; if not, write to the Free Software
19;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
20;;;;
21
22;;; Tailor this statement to your needs if necessary.
23;=GUILE_COMMENT=;(set! %load-path (cons "=GUILE_SITE=" %load-path))
24
25(use-modules (www cgi)
26 (gamma sql)
27 (gamma gettext)
28 (xmltools dict)
29 (ellinika xlat)
30 (ellinika cgi))
31(cgi:init)
32
33(define tmpl (if (and monima-nea-template-file-name
34 (cgi:value "timestamp"))
35 monima-nea-template-file-name
36 nea-template-file-name))
37
38(ellinika-cgi-init tmpl)
39
40(define conn #f)
41(define article #f)
42(define accepted-lang (map
43 (lambda (s)
44 (cond
45 ((string-split s #\;) =>
46 (lambda (l)
47 (car l)))
48 (else
49 s)))
50 (string-split (or
51 (getenv "HTTP_ACCEPT_LANGUAGE")
52 "")
53 #\,)))
54
55(define nea-max-rows 20) ;; FIXME: Move to the config
56
57(define (permalink tag timestamp)
58 (display (string-append "<" tag " class=\"permalink\">"))
59 (display "<a href=\"")
60 (display (make-cgi-name nea-cgi-path "timestamp" timestamp))
61 (display "\">[permanent link]</a>")
62 (display (string-append "</" tag ">")))
63
64(define (sql-error-handler err descr)
65 (format #t "<h1 class=\"error\">~A</h1>\n"
66 (_ "ΣΦΆΛΜΑ: σύνδεση με την βάση δεδομένων απέτυχε."))
67 (with-output-to-port
68 (current-error-port)
69 (lambda ()
70 (display err)
71 (display ": ")
72 (display descr))))
73
74(defmacro catch-sql (expr)
75 `(catch 'gsql-error
76 (lambda () ,expr)
77 (lambda (key err descr)
78 (sql-error-handler err descr))))
79
80(defmacro assert-article (. expr)
81 `(if article
82 (cond
83 ((null? article)
84 (format #t "<h1 class=\"error\">~A</h1>\n"
85 (_ "Κάμια καταχώρηση")))
86 (else
87 ,@expr))))
88
89(define (make-sql-list input-list)
90 (let loop ((str "")
91 (input-list input-list))
92 (if (null? input-list)
93 (string-append "(" str ")")
94 (loop (string-append str
95 (if (string-null? str) "'" ",'")
96 (car input-list) "'")
97 (cdr input-list)))))
98
99(define (get-sql-lang conn ident langlist)
100 (let ((res (map car (sql-query conn
101 (string-append
102 "SELECT lang "
103 "FROM newsart "
104 "WHERE ident=" ident " "
105 "AND lang in " (make-sql-list langlist))))))
106 (cond
107 ((null? res)
108 #f)
109 (else
110 (call-with-current-continuation
111 (lambda (return)
112 (for-each
113 (lambda (elt)
114 (if (member elt res)
115 (return elt)))
116 langlist)))))))
117
118(define (make-my-lang-list)
119 (map language-code (cons target-language
120 accepted-lang)))
121
122
123(define (collect-entries from fwd)
124 (let loop ((start from)
125 (result '()))
126 (cond
127 ((not fwd)
128 (set! start (- start nea-max-rows))
129 (if (< start 0)
130 (set! start 0))))
131 (call-with-current-continuation
132 (lambda (return)
133 (let ((tuples (sql-query
134 conn
135 (format #f
136 "SELECT date,ident FROM news ORDER BY 1 DESC LIMIT ~A,~A"
137 start nea-max-rows))))
138 (cond
139 ((null? tuples)
140 (cons start (if fwd (reverse result) result)))
141 (else
142 (let ((langlist (make-my-lang-list))
143 (rest (- nea-max-rows (length result)))
144 (ctr 0))
145 (for-each
146 (lambda (entry)
147 (let ((lang (get-sql-lang conn (list-ref entry 1) langlist)))
148 (set! ctr (1+ ctr))
149 (if lang
150 (let ((hdr (sql-query conn
151 (string-append
152 "SELECT header,lang "
153 "FROM newsart "
154 "WHERE ident=" (list-ref entry 1) " "
155 "AND lang='" lang "' "
156 "LIMIT 1"))))
157 (cond
158 (hdr
159 (set! result (cons
160 (cons (caar hdr) entry)
161 result))
162 (set! rest (1- rest))
163 (cond
164 ((= 0 rest)
165 (if fwd
166 (return (cons (+ ctr start) (reverse result)))
167 (return (cons (+ start (- nea-max-rows ctr))
168 result)))))))))))
169
170 (if fwd
171 tuples
172 (reverse tuples)))
173
174 (cond
175 ((and (not fwd) (= 0 start))
176 (cons start (if fwd (reverse result) result)))
177 (else
178 (if fwd
179 (set! start (+ ctr start)))
180 (loop start result)))))))))))
181
182(define (summary)
183 (catch-sql
184 (let* ((count (catch #t
185 (lambda ()
186 (string->number
187 (caar (sql-query conn "SELECT count(*) FROM news"))))
188 (lambda args
189 0)))
190 (from (catch #t
191 (lambda ()
192 (let ((x (string->number (cgi:value "from"))))
193 (if (< x count)
194 x
195 0)))
196 (lambda args
197 0)))
198 (fwd (let ((dir (cgi:value "dir")))
199 (or (not dir)
200 (string=? dir "1"))))
201 (entries (collect-entries from fwd)))
202
203 (let ((start (car entries))
204 (result (cdr entries)))
205 (cond
206 ((null? result)
207 (display "<div align=\"center\">")
208 (display (_ "Κανένα νέα"))
209 (display "</div>"))
210 (else
211 (let ((num-entries (length result))
212 (begin (if fwd from start))
213 (end (if fwd start from))
214 (id (cgi:value "id")))
215
216 (cond
217 ((not (and (= from 0) (< num-entries nea-max-rows)))
218 (display "<p>")
219 (format #t (_ "Εγγραφείς ~A - ~A") begin end)
220 (display "</p>")))
221
222 (display "<table class=\"news-summary frame\">\n")
223 (let ((ctr 0)
224 (langlist (make-my-lang-list)))
225 (for-each
226 (lambda (entry)
227 (display "<tr class=\"")
228 (display (if (= (modulo ctr 2) 0) "even" "odd"))
229 (display "\">\n")
230 (set! ctr (1+ ctr))
231 (display "<td class=\"date\">")
232 (display (list-ref entry 1))
233 (display "</td>")
234 (display "<td class=\"subject")
235<