summaryrefslogtreecommitdiffabout
path: root/cgi-bin/nea.scm4
Unidiff
Diffstat (limited to 'cgi-bin/nea.scm4') (more/less context) (ignore whitespace changes)
-rw-r--r--cgi-bin/nea.scm4536
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
--- a/dev/null
+++ b/cgi-bin/nea.scm4
@@ -0,0 +1,536 @@
1;;;; News page for Ellinika
2;;;; Copyright (C) 2004, 2005, 2006 Sergey Poznyakoff
3;;;;
4;;;; This program is free software; you can redistribute it and/or modify
5;;;; it under the terms of the GNU General Public License as published by
6;;;; the Free Software Foundation; either version 2 of the License, or
7;;;; (at your option) any later version.
8;;;;
9;;;; This program is distributed in the hope that it will be useful,
10;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12;;;; GNU General Public License for more details.
13;;;;
14;;;; You should have received a copy of the GNU General Public License
15;;;; along with this program; if not, write to the Free Software
16;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
17;;;;
18
19;;; Tailor this statement to your needs if necessary.
20(set! %load-path (cons "GUILE_SITE" %load-path))
21
22(use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user))
23 (gamma sql)
24 (gamma gettext)
25 (xmltools dict)
26 (ellinika xlat)
27 (ellinika cgi))
28
29ifelse(IFACE,[CGI],(cgi:init))
30
31(define tmpl (if (and monima-nea-template-file-name
32 (cgi:value "timestamp"))
33 monima-nea-template-file-name
34 nea-template-file-name))
35
36(ellinika-cgi-init tmpl)
37
38(define conn #f)
39(define article #f)
40(define accepted-lang (map
41 (lambda (s)
42 (cond
43 ((string-split s #\;) =>
44 (lambda (l)
45 (car l)))
46 (else
47 s)))
48 (string-split (or
49 (getenv "HTTP_ACCEPT_LANGUAGE")
50 "")
51 #\,)))
52
53(define nea-max-rows 20) ;; FIXME: Move to the config
54
55(define (permalink tag timestamp)
56 (display (string-append "<" tag " class=\"permalink\">"))
57 (display "<a href=\"")
58 (display (make-cgi-name cgi-script-name "timestamp" timestamp))
59 (display "\">[permanent link]</a>")
60 (display (string-append "</" tag ">")))
61
62(define (sql-error-handler err descr)
63 (format #t "<h1 class=\"error\">~A</h1>\n"
64 (_ "ΣΦΆΛΜΑ: σύνδεση με την βάση δεδομένων απέτυχε."))
65 (with-output-to-port
66 (current-error-port)
67 (lambda ()
68 (display err)
69 (display ": ")
70 (display descr))))
71
72(defmacro catch-sql (expr)
73 `(catch 'gsql-error
74 (lambda () ,expr)
75 (lambda (key err descr)
76 (sql-error-handler err descr))))
77
78(defmacro assert-article (. expr)
79 `(if article
80 (cond
81 ((null? article)
82 (format #t "<h1 class=\"error\">~A</h1>\n"
83 (_ "Κάμια καταχώρηση")))
84 (else
85 ,@expr))))
86
87(define (make-sql-list input-list)
88 (let loop ((str "")
89 (input-list input-list))
90 (if (null? input-list)
91 (string-append "(" str ")")
92 (loop (string-append str
93 (if (string-null? str) "'" ",'")
94 (car input-list) "'")
95 (cdr input-list)))))
96
97(define (get-sql-lang conn ident langlist)
98 (let ((res (map car (sql-query conn
99 (string-append
100 "SELECT lang "
101 "FROM newsart "
102 "WHERE ident=" ident " "
103 "AND lang in " (make-sql-list langlist))))))
104 (cond
105 ((null? res)
106 #f)
107 (else
108 (call-with-current-continuation
109 (lambda (return)
110 (for-each
111 (lambda (elt)
112 (if (member elt res)
113 (return elt)))
114 langlist)))))))
115
116(define (make-my-lang-list)
117 (map language-code (cons target-language
118 accepted-lang)))
119
120
121(define (collect-entries from fwd)
122 (let loop ((start from)
123 (result '()))
124 (cond
125 ((not fwd)
126 (set! start (- start nea-max-rows))
127 (if (< start 0)
128 (set! start 0))))
129 (call-with-current-continuation
130 (lambda (return)
131 (let ((tuples (sql-query
132 conn
133 (format #f
134 "SELECT date,ident FROM news ORDER BY 1 DESC LIMIT ~A,~A"
135 start nea-max-rows))))
136 (cond
137 ((null? tuples)
138 (cons start (if fwd (reverse result) result)))
139 (else
140 (let ((langlist (make-my-lang-list))
141 (rest (- nea-max-rows (length result)))
142 (ctr 0))
143 (for-each
144 (lambda (entry)
145 (let ((lang (get-sql-lang conn (list-ref entry 1) langlist)))
146 (set! ctr (1+ ctr))
147 (if lang
148 (let ((hdr (sql-query conn
149 (string-append
150 "SELECT header,lang "
151 "FROM newsart "
152 "WHERE ident=" (list-ref entry 1) " "
153 "AND lang='" lang "' "
154 "LIMIT 1"))))
155 (cond
156 (hdr
157 (set! result (cons
158 (cons (caar hdr) entry)
159 result))
160 (set! rest (1- rest))
161 (cond
162 ((= 0 rest)
163 (if fwd
164 (return (cons (+ ctr start) (reverse result)))
165 (return (cons (+ start (- nea-max-rows ctr))
166 result)))))))))))
167
168 (if fwd
169 tuples
170 (reverse tuples)))
171
172 (cond
173 ((and (not fwd) (= 0 start))
174 (cons start (if fwd (reverse result) result)))
175 (else
176 (if fwd
177 (set! start (+ ctr start)))
178 (loop start result)))))))))))
179
180(define (summary)
181 (catch-sql
182 (let* ((count (catch #t
183 (lambda ()
184 (string->number
185 (caar (sql-query conn "SELECT count(*) FROM news"))))
186 (lambda args
187 0)))
188 (from (catch #t
189 (lambda ()
190 (let ((x (string->number (cgi:value "from"))))
191 (if (< x count)
192 x
193 0)))
194 (lambda args
195 0)))
196 (fwd (let ((dir (cgi:value "dir")))
197 (or (not dir)
198 (string=? dir "1"))))
199 (entries (collect-entries from fwd)))
200
201 (let ((start (car entries))
202 (result (cdr entries)))
203 (cond
204 ((null? result)
205 (display "<div align=\"center\">")
206 (display (_ "Κανένα νέα"))
207 (display "</div>"))
208 (else
209 (let ((num-entries (length result))
210 (begin (if fwd from start))
211 (end (if fwd start from))
212 (id (cgi:value "id")))
213
214 (cond
215 ((not (and (= from 0) (< num-entries nea-max-rows)))
216 (display "<p>")
217 (format #t (_ "Εγγραφείς ~A - ~A") begin end)
218 (display "</p>")))
219
220 (display "<table class=\"news-summary frame\">\n")
221 (let ((ctr 0)
222 (langlist (make-my-lang-list)))
223 (for-each
224 (lambda (entry)
225 (display "<tr class=\"")
226 (display (if (= (modulo ctr 2) 0) "even" "odd"))
227 (display "\">\n")
228 (set! ctr (1+ ctr))
229 (display "<td class=\"date\">")
230 (display (list-ref entry 1))
231 (display "</td>")
232 (display "<td class=\"subject")
233 (cond
234 ((and id (string=? (list-ref entry 2) id))
235 (display " current\">")
236 (display (list-ref entry 0)))
237 (else
238 (display "\"><a href=\"")
239 (display (make-cgi-name cgi-script-name
240 "id" (list-ref entry 2)
241 "from" (number->string begin)))
242 (display "\">")
243 (display (list-ref entry 0))
244 (display "</a>")))
245 (display "</td>")
246 (display "\n</tr>\n"))
247 result))
248 (display "</table>")
249
250 (display "<div class=\"menu-bar\" align=\"center\">")
251 (cond
252 ((> begin 0)
253 (display "<span class=\"menu-cell\"><a href=\"")
254 (display (apply make-cgi-name
255 cgi-script-name
256 "from" (number->string begin)
257 "dir" "0"
258 (if id
259 (list "id" id)
260 '())))
261 (display "\">")
262 (display (_ "Προηγούμενες"))
263 (display "</a></span>")))
264
265 (cond
266 ((< end count)
267 (display "<span class=\"menu-cell\"><a href=\"")
268 (display (apply make-cgi-name
269 cgi-script-name
270 "from" (number->string end)
271 "dir" "1"
272 (if id
273 (list "id" id)
274 '())))
275 (display "\">")
276 (display (_ "Ερχόμενες"))
277 (display "</a></span>")))
278 (display "</div>"))))))))
279
280(define (display-article-header item)
281 (display "<div id=\"news-header\">")
282 (format #t "<span class=\"itemdate\">~A</span>\n" (car item))
283 (display "<span class=\"itemsubject\">\n")
284 (display (list-ref item 2))
285 (display "</span>")
286 (if (not (cgi:value "timestamp"))
287 (permalink "span" (list-ref item 1)))
288 (display "</div><!-- news-header -->"))
289
290(define (display-article-text item . rest)
291 (let ((class (and (not (null? rest)) (car rest))))
292 (cond
293 (class
294 (display "\n<div class=\"")
295 (display class)
296 (display "\">\n")
297 (display (list-ref item 3))
298 (display "</div>\n"))
299 (else
300 (display (list-ref item 3))))))
301
302(define (main)
303 (catch-sql
304 (assert-article
305 (display-article-header article)
306 (display-article-text article "itemtext"))))
307
308(define (title)
309 (if article
310 (display (if (null? article)
311 (string-append
312 "<h1 class=\"error\">"
313 (_ "Κάμια καταχώρηση")
314 "</h1>")
315 (list-ref article 2)))))
316
317
318(define (nea-html)
319 (let ((explist (list (cons "@@main@@" main)
320 (cons "@@summary@@" summary)
321 (cons "@@title@@" title)
322 (cons "@@article-text@@"
323 (lambda ()
324 (catch-sql
325 (assert-article
326 (display-article-text article)))))
327 (cons "@@article-date@@"
328 (lambda ()
329 (catch-sql
330 (assert-article
331 (display (car article))))))
332 (cons "@@article-header@@"
333 (lambda ()
334 (catch-sql
335 (assert-article
336 (display (list-ref article 2))))))
337 (cons "@@full-header@@"
338 (lambda ()
339 (catch-sql
340 (assert-article
341 (display-article-header
342 article)))))
343 (cons "@@args@@"
344 (lambda ()
345 (for-each
346 (lambda (name)
347 (cond
348 ((string=? name "LANG"))
349 (else
350 (let ((v (cgi:value name)))
351 (cond ((and v (not (string-null? v)))
352 (display "&amp;")
353 (display name)
354 (display "=")
355 (display v)))))))
356 (cgi:names)))))))
357
358 (do ((line (read-line) (read-line)))
359 ((eof-object? line) #f)
360 (expand-template explist line)
361 (newline))))
362
363(define (nea-rss-header)
364 (display "<?xml version=\"1.0\"?>\n")
365 (display "<rss version=\"2.0\">
366 <channel>
367 <title>Τα νέα</title>
368 <description>Τα νέα</description>
369 <link>http://ellinika.gnu.org.ua</link>")
370 (format #t "<language>~A</language>" (language-code target-language))
371 (display "
372 <generator>EllinikaNea</generator>
373 <copyright>2006 Sergey Poznyakoff</copyright>
374 <managingEditor>gray@gnu.org.ua</managingEditor>
375 <docs>http://blogs.law.harvard.edu/tech/rss</docs>
376"))
377
378(define (nea-rss-footer)
379 (display " </channel>
380</rss>"))
381
382(define (nea-sql-connect)
383 (let ((conn (sql-connect
384 sql-iface sql-host sql-port sql-database
385 sql-username sql-password)))
386 (sql-query conn "SET NAMES utf8")
387 conn))
388
389(define (nea-rss)
390 (nea-rss-header)
391 (catch 'gsql-error
392 (lambda ()
393 (let ((conn (nea-sql-connect)))
394 (for-each
395 (lambda (tuple)
396 (display "<item>\n")
397 (display "<pubDate>")
398 (display (list-ref tuple 0))
399 (display "</pubDate>\n")
400 (display "<title>")
401 (let ((title (sql-query conn
402 (string-append
403 "SELECT header "
404 "FROM newsart "
405 "WHERE ident=" (list-ref tuple 2) " "
406 "AND lang='"
407 (get-sql-lang conn
408 (list-ref tuple 2)
409 (make-my-lang-list))
410 "' "
411 "LIMIT 1"))))
412 (display (if (not (null? title))
413 (caar title)
414 (list-ref tuple 0))))
415 (display "</title>\n")
416 (display "<link>")
417 (display (string-append
418 (string-downcase cgi-server-protocol-name)
419 "://"
420 cgi-server-hostname
421 "/"
422 (make-cgi-name cgi-script-name
423 "timestamp" (list-ref tuple 1))))
424 (display "</link>\n")
425 (display "</item>\n"))
426 (sql-query
427 conn
428 (string-append
429 "SELECT date,unix_timestamp(date),ident "
430 "FROM news "
431 "ORDER BY 1 DESC LIMIT 10")))))
432 (lambda (key err descr)
433 (sql-error-handler err descr)))
434 (nea-rss-footer))
435
436
437(define (get-article-by-timestamp ts)
438 (let ((tuples (sql-query
439 conn
440 "SELECT date,unix_timestamp(date),ident FROM news WHERE unix_timestamp(date)=" ts)))
441 (cond
442 (tuples
443 (let* ((res (car tuples))
444 (lang (get-sql-lang conn (list-ref res 2) (make-my-lang-list)))
445 (art (sql-query conn
446 (string-append
447 "SELECT header,text,lang "
448 "FROM newsart "
449 "WHERE ident=" (list-ref res 2) " "
450 "AND lang='" lang "' "
451 "LIMIT 1"))))
452 (append
453 (list (list-ref res 0)
454 (list-ref res 1))
455 (car art)))))))
456
457
458;;; Main
459
460(cond
461 ((cgi:value "rss")
462 ifelse(IFACE,[CGI],
463 (display ["Content-type: text/xml; charset=utf-8\r\n\r\n"]),
464 (request-rec:set-content-type! Request ["text/xml; charset=UTF-8"]))
465 (nea-rss))
466 (else
467 (catch 'gsql-error
468 (lambda ()
469 ifelse(IFACE,[CGI],dnl
470 (display ["Content-type: text/html; charset=utf-8\r\n\r\n"]))
471 (set! conn (nea-sql-connect))
472 (cond
473 ((or (cgi:value "timestamp") (cgi:value "id"))
474 (let ((tuples (sql-query
475 conn
476 (string-append
477 "SELECT date,unix_timestamp(date),ident "
478 "FROM news "
479 "WHERE "
480 (cond
481 ((cgi:value "timestamp") =>
482 (lambda (ts)
483 (string-append "unix_timestamp(date)=" ts)))
484 ((cgi:value "id") =>
485 (lambda (id)
486 (string-append "ident=" id))))))))
487
488 (if (not (null? tuples))
489 (let* ((res (car tuples))
490 (lang (get-sql-lang conn
491 (list-ref res 2)
492 (make-my-lang-list)))
493 (art (sql-query
494 conn
495 (string-append
496 "SELECT header,text,lang "
497 "FROM newsart "
498 "WHERE ident=" (list-ref res 2) " "
499 "AND lang='" lang "' "
500 "LIMIT 1"))))
501 (set! article (append
502 (list (list-ref res 0)
503 (list-ref res 1))
504 (car art))))))))
505
506 (with-input-from-file
507 (template-file target-language tmpl)
508 nea-html)
509
510 (sql-connect-close conn))
511
512 (lambda (key err descr)
513 (with-input-from-file
514 (template-file target-language tmpl)
515 (lambda ()
516 (let ((explist
517 (list (cons "@@main@@"
518 (lambda ()
519 (sql-error-handler err descr)))
520 (cons "@@article-text@@"
521 (lambda ()
522 (sql-error-handler err descr)))
523 (cons "@@summary@@" (lambda () #f))
524 (cons "@@title@@" (lambda () #f))
525 (cons "@@article-date@@" (lambda () #f))
526 (cons "@@article-header@@" (lambda () #f))
527 (cons "@@full-header@@" (lambda () #f)))))
528 (do ((line (read-line) (read-line)))
529 ((eof-object? line) #f)
530 (expand-template explist line)
531 (newline)))))))))
532
533;;;; Local variables:
534;;;; mode: Scheme
535;;;; buffer-file-coding-system: utf-8
536;;;; End:

Return to:

Send suggestions and report system problems to the System administrator.