diff options
Diffstat (limited to 'cgi-bin/nea.cgi.in')
-rw-r--r-- | cgi-bin/nea.cgi.in | 534 |
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< |