summaryrefslogtreecommitdiffabout
authorSergey Poznyakoff <gray@gnu.org.ua>2006-10-08 21:40:09 (GMT)
committer Sergey Poznyakoff <gray@gnu.org.ua>2006-10-08 21:40:09 (GMT)
commit109cf4d84378cbfce6b157ac854383be2a9ea866 (patch) (unidiff)
tree9c1b4a25f39d3f7bf7a8ecf879b1b40014f4af5a
parentc4a4896b38006d9966ffd6112e27539ba0efeaca (diff)
downloadellinika-109cf4d84378cbfce6b157ac854383be2a9ea866.tar.gz
ellinika-109cf4d84378cbfce6b157ac854383be2a9ea866.tar.bz2
*** empty log message ***
git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@460 941c8c0f-9102-463b-b60b-cd22ce0e6858
Diffstat (more/less context) (ignore whitespace changes)
-rw-r--r--cgi-bin/dict.scm4621
-rw-r--r--cgi-bin/nea.scm4536
-rw-r--r--ellinika/cgi.scm4 (renamed from ellinika/cgi.scmi)41
3 files changed, 1185 insertions, 13 deletions
diff --git a/cgi-bin/dict.scm4 b/cgi-bin/dict.scm4
new file mode 100644
index 0000000..ab445d4
--- a/dev/null
+++ b/cgi-bin/dict.scm4
@@ -0,0 +1,621 @@
1;;;; Greek Dictionary Web Engine
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 (ice-9 rdelim)
24 (gamma sql)
25 (gamma gettext)
26 (xmltools dict)
27 (ellinika xlat)
28 (ellinika cgi))
29
30ifelse(IFACE,[CGI],(cgi:init))
31
32(ellinika-cgi-init dict-template-file-name)
33
34;; Τα μέρη του λογου
35(define part-of-speech '())
36
37(define (sql-error-handler err descr)
38 (format #t "<h1 class=\"error\">~A</h1>\n"
39 (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε."))
40 (with-output-to-port
41 (current-error-port)
42 (lambda ()
43 (display err)
44 (display ": ")
45 (display descr))))
46
47(define (mk-dict-connect)
48 (let ((db-connection #f))
49 (lambda (. rest)
50 (cond
51 ((null? rest)
52 (if (not db-connection)
53 (begin
54 (set! db-connection
55 (sql-connect
56 sql-iface sql-host sql-port sql-database
57 sql-username sql-password))
58 (sql-query db-connection "SET NAMES utf8")
59 )))
60 (else
61 (if db-connection
62 (sql-connect-close db-connection))
63 (set! db-connection #f)))
64 db-connection)))
65
66(define dict-connect (mk-dict-connect))
67
68(defmacro catch-sql-failure (expr)
69 `(catch 'gsql-error
70 (lambda () ,expr)
71 (lambda (key err descr)
72 (sql-error-handler err descr))))
73
74(defmacro ignore-sql-failure (expr)
75 `(catch 'gsql-error
76 (lambda () ,expr)
77 (lambda (key err descr)
78 #f)))
79
80(define (load-pos)
81 (ignore-sql-failure
82 (let ((conn (dict-connect)))
83 (let ((plist (my-sql-query
84 conn
85 "SELECT name,id FROM pos WHERE canonical='Y' order by id")))
86 (set! part-of-speech
87 (cons
88 (cons "κανένα μέρος του λόγου" #f)
89 (map
90 (lambda (x)
91 (cons (car x) (cadr x)))
92 plist)))))))
93
94;; Protect occurences of " in a string.
95;; Usual backslash escapes do not work in INPUT widgets, so I
96;; change all quotation marks to &#34;
97;; Possibly not the better solution, though...
98(define (protect string)
99 (list->string
100 (apply append
101 (map
102 (lambda (x)
103 (if (eq? x #\")
104 (list #\& #\# #\3 #\4 #\;)
105 (list x)))
106 (string->list string)))))
107
108(define (get-topic-list)
109 (let ((categories #f))
110 (letrec ((getcat
111 (lambda ()
112 (ignore-sql-failure
113 (let ((conn (dict-connect)))
114 (let ((ctg (my-sql-query
115 conn
116 (string-append
117 "SELECT t.category, c.title, c.description "
118 "FROM category c,topic t "
119 "WHERE c.lang='" (language-code target-language) "' "
120 "AND c.category=t.category GROUP BY 1 ORDER BY 1"))))
121 (if (null? ctg)
122 '()
123 (map
124 (lambda (category)
125 (let ((topics (my-sql-query
126 conn
127 (string-append
128 "SELECT ident,title FROM topic WHERE category="
129 (car category)
130 " ORDER BY title"))))
131 (append category (if (null? topics)
132 '()
133 (list topics)))))
134 ctg))))))))
135 (if (not categories)
136 (set! categories (or (getcat) '())))
137 categories)))
138
139(define (join-widget widget-id tabindex)
140 (let* ((name (string-append "join" widget-id))
141 (selected-choice (or (let ((s (cgi:value name)))
142 (if s
143 (string->number s)
144 #f))
145 0)))
146 (display (string-append "<SELECT NAME=\""
147 name
148 "\" TABINDEX=\""
149 tabindex
150 "\">"))
151 (display "<OPTION VALUE=\"0\"")
152 (if (= selected-choice 0)
153 (display " selected"))
154 (display ">") (display (_"και")) (display "</OPTION>")
155 (display "<OPTION VALUE=\"1\"")
156 (if (= selected-choice 1)
157 (display " selected"))
158 (display ">") (display (_"ή")) (display "</OPTION>")
159 (display "</SELECT>")))
160
161(define (main-form)
162 (load-pos)
163 (display "<FORM ACTION=\"")
164 (display (make-cgi-name cgi-script-name))
165 (display "\" METHOD=POST>
166<table class=\"noframe\">
167<tr>
168 <td>")
169 (display (_"Εισάγετε τη λέξη"))
170 (display "
171 </td>
172 <td>
173 <input size=\"36\" name=\"key\" tabindex=\"1\"")
174 (let ((value (cgi:value "key")))
175 (if value
176 (begin
177 (display "value=\"")
178 (display (protect value))
179 (display "\""))))
180 (display ">
181 </td>
182</tr>")
183
184 (display "<tr><td colspan=\"3\" align=\"center\">")
185 (display (_"Συμπληρωματικοί όροι"))
186 (display "</td></tr>")
187
188 (display "
189<tr>
190 <td>")
191 (display (_"Επιλέξτε το μέρος του λόγου"))
192 (display "</td><td>")
193
194 (let ((selected-choice (or (let ((s (cgi:value "POS")))
195 (if s
196 (string->number s)
197 #f))
198 0))
199 (index 0))
200
201 (display "<select name=\"POS\" tabindex=\"2\">")
202
203 (for-each
204 (lambda (x)
205 (let ((name (car x)))
206 (display "<option value=")
207 (display index)
208 (if (= index selected-choice)
209 (display " selected"))
210 (display ">")
211 (display name)
212 (set! index (1+ index))))
213 part-of-speech)
214 (display "</select>"))
215
216 (display "</td><td>")
217 (join-widget "pos" "3")
218 (display "</td></tr>")
219
220 (let ((tabindex 4))
221 (for-each
222 (lambda (category)
223 (display "<tr><td>")
224 (display (list-ref category 1))
225 (display "</td><td>")
226 (let ((selected-choice (or (let ((s (cgi:value (list-ref category 0))))
227 (if s
228 (string->number s)
229 #f))
230 0)))
231
232 (display (string-append
233 "<select name=\""
234 (list-ref category 0)
235 "\" tabindex=\""
236 (number->string tabindex)
237 "\">"))
238 (set! tabindex (1+ tabindex))
239 (display "<option value=0>---")
240 (for-each
241 (lambda (x)
242 (let ((id (car x))
243 (name (car (cdr x))))
244 (display "<option value=")
245 (display id)
246 (if (eq? (string->number id) selected-choice)
247 (display " selected"))
248 (display ">")
249 (display name)
250 (display "</option>")))
251 (list-ref category 3))
252 (display "</select>")
253 (display "</td><td>")
254 (join-widget (list-ref category 0) (number->string tabindex))
255 (display "</td></tr>")
256 (set! tabindex (1+ tabindex))))
257 (get-topic-list))
258
259 (display "
260<tr>
261 <td colspan=\"3\" align=\"center\">
262 <input type=\"submit\" name=\"search\" value=\"")
263 (display (_"Αναζήτηση"))
264 (display "\" tabindex=\"")
265 (display tabindex)
266 (display "\">
267 </td>
268</tr>
269</table>
270</form>
271<p>")))
272
273;;
274(define (replace-tilde word sentence)
275 (apply
276 string-append
277 (let loop ((lst '())
278 (str sentence))
279 (cond
280 ((string-index str #\~) =>
281 (lambda (x)
282 (loop
283 (append lst (list (substring str 0 x) word))
284 (substring str (1+ x)))))
285 ((string-null? str)
286 lst)
287 (else
288 (append lst (list str)))))))
289
290;;
291(define (display-results rlist)
292 (let ((x (car rlist)))
293 (display "<table class=\"noframe\">")
294 (display "<tr><td>")
295 (display (car x))
296 (display "</td>")
297 (cond
298 ((list-ref x 3)
299 (display "<td>")
300 (let ((href (assoc (list-ref x 2) word-forms-reference)))
301 (cond
302 (href
303 (display "<a href=\"")
304 (cond
305 (ref-loc
306 (display ref-loc)
307 (display "/")))
308 (display (language-code target-language))
309 (display "/")
310 (display (cdr href))
311 (display (dict:encode-string (car x)))
312 (display "\">")
313 (display (list-ref x 3))
314 (display "</a>"))
315 (else
316 (display (list-ref x 3)))))
317 (display "</td>")))
318 (display "<td>")
319 (display (list-ref x 2))
320 (display "</td></tr>"))
321 (for-each
322 (lambda (x)
323 (display "<tr><td>")
324 (display (1+ (string->number (list-ref x 4))))
325 (display "</td><td>")
326 (display (replace-tilde (car x) (list-ref x 5)))
327 (display ";</td></tr>"))
328 rlist)
329 (display "</table>")
330 (newline))
331
332(define (display-cross-reference word)
333 (display "<a href=\"")
334 (display (make-cgi-name cgi-script-name "IDENT" (dict:encode-string word)))
335 (display "\">")
336 (display word)
337 (display "</a>"))
338
339(define (display-xref rlist text)
340 (display text)
341 (let ((n 0))
342 (for-each
343 (lambda (x)
344 (if (> n 0)
345 (display ", "))
346 (set! n (1+ n))
347 (display-cross-reference (car x)))
348 rlist))
349 (display ";"))
350
351(define (sort-result input-list)
352 (let ((output-list '())
353 (current-element '()))
354 (for-each
355 (lambda (x)
356 (cond
357 ((or (null? current-element)
358 (= (string->number (cadr x))
359 (string->number (cadr (car current-element)))))
360 (set! current-element (cons x current-element)))
361 (else
362 (set! output-list (cons (reverse current-element) output-list))
363 (set! current-element (list x)))))
364 input-list)
365 (cons (reverse current-element) output-list)))
366
367
368(define (search-failure key)
369 (display "<h2>")
370 (format #t (_"Συγγνώμη, η λέξη \"~A\" δεν βρέθηκε στο λέξικο.") key)
371 (display "</h2>"))
372
373(define (my-sql-query conn query)
374 (catch #t
375 (lambda ()
376 (sql-query conn query))
377 (lambda args
378 '())))
379
380(define (fuzzy-search conn key theme pos)
381 (let ((where-cond (list (string-append
382 "WHERE dict.ident=articles.ident and articles.lang='"
383 (language-code target-language)
384 "' AND")))
385 (select-stmt "SELECT DISTINCT dict.word FROM ")
386 (from-list (list ",articles" "dict")))
387
388 (cond
389 ((not (null? theme))
390 (set! where-cond (cons " topic_tab.word_ident=dict.ident"
391 where-cond))
392 (set! from-list (cons ",topic_tab" from-list))))
393
394 (cond
395 ((not (string-null? key))
396 (if (not (null? theme))
397 (set! where-cond (cons " AND" where-cond)))
398 (set! where-cond (cons (string-append
399 " dict.sound LIKE \""
400 (ellinika:sounds-like key)
401 "%\"")
402 where-cond))))
403
404 (cond
405 ((> (string->number pos) 0)
406 (let ((pos-entry
407 (list-ref part-of-speech (string->number pos))))
408 (if (or (not (string-null? key)) (not (null? theme)))
409 (set! where-cond (cons
410 (if (string=? (cgi:value "joinpos") "0")
411 " AND"
412 " OR")
413 where-cond)))
414
415 (set! where-cond (cons
416 (string-append " (dict.pos & "
417 (cdr pos-entry)
418 ") = "
419 (cdr pos-entry))
420 where-cond)))))
421
422 (let ((result
423 (my-sql-query conn
424 (string-append
425 select-stmt
426
427 " "
428
429 (apply
430 string-append
431 (reverse from-list))
432
433 " "
434
435 (apply
436 string-append
437 (append
438 (reverse where-cond)
439 (map
440 (lambda (x)
441 (cond
442 ((boolean? x)
443 (if x " AND" " OR"))
444 (else
445 (if (not (member ",topic_tab" from-list))
446 (set! from-list
447 (cons ",topic_tab"
448 from-list)))
449 (string-append
450 " topic_tab.topic_ident=" x))))
451 theme)))
452
453 " ORDER BY dict.word"))))
454
455 (cond
456 ((null? result)
457 (search-failure key))
458 (else
459 (display "<table width=\"100%\" class=\"noframe\">")
460 (let* ((result-length (length result))
461 (lim (1+ (inexact->exact (/ result-length match-list-columns)))))
462 (do ((i 0 (1+ i)))
463 ((= i lim) #f)
464 (display "<tr>")
465 (do ((j i (+ j lim)))
466 ((>= j result-length) #f)
467 (display "<td>")
468 (display-cross-reference (car (list-ref result j)))
469 (display "</td>"))
470 (display "</tr>")))
471 (display "</table>"))))))
472
473
474(define (dict-search)
475 (let ((keyval (if (cgi:value "IDENT")
476 (dict:decode-string (cgi:value "IDENT"))
477 (cgi:value "key")))
478 (theme (do ((catlist (get-topic-list) (cdr catlist))
479 (ret '()))
480 ((null? catlist) ret)
481 (let ((name (caar catlist)))
482 (let ((v (cgi:value name)))
483 (if (and v (> (string->number v) 0))
484 (set! ret (append
485 ret
486 (list (= (string->number
487 (cgi:value (string-append "join" name))) 0)
488 v))))))))
489 (pos (or (cgi:value "POS") "0")))
490
491 (catch-sql-failure
492 (let ((conn (dict-connect)))
493 (cond
494 ((and keyval
495 (not (string-null? keyval))
496 (null? theme)
497 (= (string->number pos) 0))
498 (display "<hr>")
499 (let* ((key (ellinika:translate-input keyval))
500 (result (my-sql-query
501 conn
502 (string-append
503 "SELECT dict.word,dict.ident,pos.abbr,dict.forms,articles.subindex,articles.meaning "
504 "FROM dict,articles,pos WHERE dict.word=\""
505 key
506 "\" AND dict.ident=articles.ident "
507 "AND articles.lang='" (language-code target-language) "' "
508 "AND dict.pos=pos.id AND pos.canonical='Y' order by dict.ident, articles.subindex"))))
509
510 (cond
511 ((null? result)
512 (fuzzy-search conn key theme pos))
513 (else
514 (for-each
515 (lambda (entry)
516 (display-results entry)
517 (let ((ant (my-sql-query
518 conn
519 (string-append
520 "SELECT dict.word FROM dict,links WHERE links.type='ANT' AND links.ident="
521 (cadr (car entry))
522 " AND dict.ident=links.xref ORDER BY word"))))
523 (if (and ant (not (null? ant)))
524 (display-xref ant
525 (if (= (length ant) 1)
526 (_"Αντώνυμο: ") (_"Αντώνυμα: ")))))
527 (display "<p>")
528 (let ((x (my-sql-query
529 conn
530 (string-append
531 "SELECT dict.word FROM dict,links WHERE links.type='XREF' AND links.ident="
532 (cadr (car entry))
533 " AND dict.ident=links.xref ORDER BY word"))))
534 (if (and x (not (null? x)))
535 (display-xref x (_"Βλέπετε επίσης ")))))
536 (sort-result result))))))
537 ((or (not (null? theme)) (> (string->number pos) 0))
538 (display "<hr>")
539 (fuzzy-search conn
540 (ellinika:translate-input (or keyval "")) theme pos)))))))
541
542;;;
543
544(define (stat key)
545 (let ((stat-data #f))
546 (if (not stat-data)
547 (set! stat-data
548 (or
549 (ignore-sql-failure
550 (my-sql-query (dict-connect)
551 (string-append
552 "SELECT count,updated from stat WHERE lang='"
553 (language-code target-language)
554 "'")))
555 '())))
556
557 (if (null? stat-data)
558 "<>"
559 (case key
560 ((#:updated)
561 (list-ref (car stat-data) 1))
562 ((#:count)
563 (list-ref (car stat-data) 0))
564 (else
565 "<>")))))
566
567
568;;;
569
570(define (dict-html)
571 (let ((explist (list
572 (cons "@@args@@"
573 (lambda ()
574 (for-each
575 (lambda (name)
576 (cond
577 ((string=? name "LANG"))
578 (else
579 (let ((v (cgi:value name)))
580 (cond ((and v (not (string-null? v)))
581 (display "&amp;")
582 (display name)
583 (display "=")
584 (display v)))))))
585 (cgi:names))))
586 (cons "@@dict@@"
587 (lambda ()
588 (main-form)
589 (dict-search)))
590 (cons "@@stat_updated@@"
591 (lambda ()
592 (display (stat #:updated))))
593 (cons "@@stat_count@@"
594 (lambda ()
595 (display
596 (let ((s (stat #:count)))
597 (if (string=? s "<>")
598 s
599 (let ((n (string->number s)))
600 (string-append s " "
601 (ngettext "λέξη" "λέξεις"
602 n)))))))))))
603 (do ((line (read-line) (read-line)))
604 ((eof-object? line) #f)
605 (expand-template explist line)
606 (newline))))
607
608;;; Main
609ifelse(IFACE,[CGI],(display ["Content-type: text/html; charset=utf-8\r\n\r\n"]))
610
611(with-input-from-file
612 (template-file target-language dict-template-file-name)
613 dict-html)
614
615(dict-connect #t)
616
617;;;; Local variables:
618;;;; mode: Scheme
619;;;; buffer-file-coding-system: utf-8
620;;;; End:
621
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:
diff --git a/ellinika/cgi.scmi b/ellinika/cgi.scm4
index b4da8f9..dc7c05d 100644
--- a/ellinika/cgi.scmi
+++ b/ellinika/cgi.scm4
@@ -1,3 +1,2 @@
1;;;; -*- scheme -*- 1;;;; -*- scheme -*-
2=AUTOGENERATED=
3;;;; Greek Dictionary Web Engine 2;;;; Greek Dictionary Web Engine
@@ -19,20 +18,36 @@
19;;;; 18;;;;
20
21(define-module (ellinika cgi)) 19(define-module (ellinika cgi))
22 20
23(use-modules (www cgi) 21(use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user))
24 (gamma gettext) 22 (gamma gettext)
25 (ellinika i18n)) 23 (ellinika i18n))
26 24
25ifelse(IFACE,[CGI],,dnl
26(define form-data
27 (append
28 (parse-form-data
29 (table:get (request-rec:subprocess-env Request) "QUERY_STRING"))
30 (if (= (request-rec:method-number Request) 2)
31 (parse-form-data (read-post-data Request))
32 '())))
33
34(define-public (cgi:value name)
35 (assoc-ref form-data name))
36
37(define-public (cgi:names)
38 (map car form-data))
39
40(define-public cgi-script-name
41 (table:get (request-rec:subprocess-env Request)
42 "SCRIPT_NAME"))
43)
44
45
27;;; User-definable variables 46;;; User-definable variables
28(define-public base-dir "=PREFIX=") 47(define-public base-dir "PREFIX")
29(define-public html-dir "=HTMLDIR=") 48(define-public html-dir "HTMLDIR")
30(define-public sysconf-dir "=SYSCONFDIR=") 49(define-public sysconf-dir "SYSCONFDIR")
31(define-public locale-path "=LOCALEDIR=:/usr/share/locale:/usr/local/share/locale") 50(define-public locale-path "LOCALEDIR:/usr/share/locale:/usr/local/share/locale")
32(define-public ref-loc #f) 51(define-public ref-loc #f)
33 52
34(define-public dict-cgi-path "cgi-bin/dict.cgi")
35(define-public nea-cgi-path "cgi-bin/nea.cgi") ;; Path to the cgi (relative
36 ;; to the Base HREF)
37
38(define-public config-file-name "ellinika.conf") 53(define-public config-file-name "ellinika.conf")
@@ -144,3 +159,3 @@ THUNK.
144;;; Initialize i18n 159;;; Initialize i18n
145 (let ((x (locale-setup target-language "=PACKAGE=" locale-path))) 160 (let ((x (locale-setup target-language "PACKAGE" locale-path)))
146 (if x 161 (if x

Return to:

Send suggestions and report system problems to the System administrator.