diff options
Diffstat (limited to 'cgi-bin/nea.scm4')
-rw-r--r-- | cgi-bin/nea.scm4 | 536 |
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 @@ | |||
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 | |||
29 | ifelse(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 |