diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2006-10-08 21:39:00 +0000 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2006-10-08 21:39:00 +0000 |
commit | c4a4896b38006d9966ffd6112e27539ba0efeaca (patch) | |
tree | 92531f80844dc3815cde1ececdebcd8d92e9c9ce | |
parent | 38cd77fba411fdc8684654bb6f163809ffe1eb46 (diff) | |
download | ellinika-c4a4896b38006d9966ffd6112e27539ba0efeaca.tar.gz ellinika-c4a4896b38006d9966ffd6112e27539ba0efeaca.tar.bz2 |
Removed
git-svn-id: file:///home/puszcza/svnroot/ellinika/trunk@459 941c8c0f-9102-463b-b60b-cd22ce0e6858
-rw-r--r-- | cgi-bin/dict.cgi.in | 622 | ||||
-rw-r--r-- | cgi-bin/nea.cgi.in | 534 | ||||
-rw-r--r-- | xml/nea.scm | 9 |
3 files changed, 0 insertions, 1165 deletions
diff --git a/cgi-bin/dict.cgi.in b/cgi-bin/dict.cgi.in deleted file mode 100644 index d087bf3..0000000 --- a/cgi-bin/dict.cgi.in +++ /dev/null @@ -1,622 +0,0 @@ -#! =GUILE_BINDIR=/guile -s -=AUTOGENERATED= -!# -;;;; Greek Dictionary Web Engine -;;;; Copyright (C) 2004, 2005 Sergey Poznyakoff -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -;;;; - -;;; Tailor this statement to your needs if necessary. -;=GUILE_COMMENT=;(set! %load-path (cons "=GUILE_SITE=" %load-path)) - -(use-modules (www cgi) - (gamma sql) - (gamma gettext) - (xmltools dict) - (ellinika xlat) - (ellinika cgi)) -(cgi:init) - -(ellinika-cgi-init dict-template-file-name) - -;; Τα μέρη του λογου -(define part-of-speech '()) - -(define (sql-error-handler err descr) - (format #t "<h1 class=\"error\">~A</h1>\n" - (_ "ΣΦΆΛΜΑ: σύνδεση με το λέξικο απέτυχε.")) - (with-output-to-port - (current-error-port) - (lambda () - (display err) - (display ": ") - (display descr)))) - -(define (mk-dict-connect) - (let ((db-connection #f)) - (lambda (. rest) - (cond - ((null? rest) - (if (not db-connection) - (begin - (set! db-connection - (sql-connect - sql-iface sql-host sql-port sql-database - sql-username sql-password)) - (sql-query db-connection "SET NAMES utf8") - ))) - (else - (if db-connection - (sql-connect-close db-connection)) - (set! db-connection #f))) - db-connection))) - -(define dict-connect (mk-dict-connect)) - -(defmacro catch-sql-failure (expr) - `(catch 'gsql-error - (lambda () ,expr) - (lambda (key err descr) - (sql-error-handler err descr)))) - -(defmacro ignore-sql-failure (expr) - `(catch 'gsql-error - (lambda () ,expr) - (lambda (key err descr) - #f))) - -(define (load-pos) - (ignore-sql-failure - (let ((conn (dict-connect))) - (let ((plist (my-sql-query - conn - "SELECT name,id FROM pos WHERE canonical='Y' order by id"))) - (set! part-of-speech - (cons - (cons "κανένα μέρος του λόγου" #f) - (map - (lambda (x) - (cons (car x) (cadr x))) - plist))))))) - -;; Protect occurences of " in a string. -;; Usual backslash escapes do not work in INPUT widgets, so I -;; change all quotation marks to " -;; Possibly not the better solution, though... -(define (protect string) - (list->string - (apply append - (map - (lambda (x) - (if (eq? x #\") - (list #\& #\# #\3 #\4 #\;) - (list x))) - (string->list string))))) - -(define (get-topic-list) - (let ((categories #f)) - (letrec ((getcat - (lambda () - (ignore-sql-failure - (let ((conn (dict-connect))) - (let ((ctg (my-sql-query - conn - (string-append - "SELECT t.category, c.title, c.description " - "FROM category c,topic t " - "WHERE c.lang='" (language-code target-language) "' " - "AND c.category=t.category GROUP BY 1 ORDER BY 1")))) - (if (null? ctg) - '() - (map - (lambda (category) - (let ((topics (my-sql-query - conn - (string-append - "SELECT ident,title FROM topic WHERE category=" - (car category) - " ORDER BY title")))) - (append category (if (null? topics) - '() - (list topics))))) - ctg)))))))) - (if (not categories) - (set! categories (or (getcat) '()))) - categories))) - -(define (join-widget widget-id tabindex) - (let* ((name (string-append "join" widget-id)) - (selected-choice (or (let ((s (cgi:value name))) - (if s - (string->number s) - #f)) - 0))) - (display (string-append "<SELECT NAME=\"" - name - "\" TABINDEX=\"" - tabindex - "\">")) - (display "<OPTION VALUE=\"0\"") - (if (= selected-choice 0) - (display " selected")) - (display ">") (display (_"και")) (display "</OPTION>") - (display "<OPTION VALUE=\"1\"") - (if (= selected-choice 1) - (display " selected")) - (display ">") (display (_"ή")) (display "</OPTION>") - (display "</SELECT>"))) - -(define (main-form) - (load-pos) - (display "<FORM ACTION=\"") - (display (make-cgi-name dict-cgi-path)) - (display "\" METHOD=POST> -<table class=\"noframe\"> -<tr> - <td>") - (display (_"Εισάγετε τη λέξη")) - (display " - </td> - <td> - <input size=\"36\" name=\"key\" tabindex=\"1\"") - (let ((value (cgi:value "key"))) - (if value - (begin - (display "value=\"") - (display (protect value)) - (display "\"")))) - (display "> - </td> -</tr>") - - (display "<tr><td colspan=\"3\" align=\"center\">") - (display (_"Συμπληρωματικοί όροι")) - (display "</td></tr>") - - (display " -<tr> - <td>") - (display (_"Επιλέξτε το μέρος του λόγου")) - (display "</td><td>") - - (let ((selected-choice (or (let ((s (cgi:value "POS"))) - (if s - (string->number s) - #f)) - 0)) - (index 0)) - - (display "<select name=\"POS\" tabindex=\"2\">") - - (for-each - (lambda (x) - (let ((name (car x))) - (display "<option value=") - (display index) - (if (= index selected-choice) - (display " selected")) - (display ">") - (display name) - (set! index (1+ index)))) - part-of-speech) - (display "</select>")) - - (display "</td><td>") - (join-widget "pos" "3") - (display "</td></tr>") - - (let ((tabindex 4)) - (for-each - (lambda (category) - (display "<tr><td>") - (display (list-ref category 1)) - (display "</td><td>") - (let ((selected-choice (or (let ((s (cgi:value (list-ref category 0)))) - (if s - (string->number s) - #f)) - 0))) - - (display (string-append - "<select name=\"" - (list-ref category 0) - "\" tabindex=\"" - (number->string tabindex) - "\">")) - (set! tabindex (1+ tabindex)) - (display "<option value=0>---") - (for-each - (lambda (x) - (let ((id (car x)) - (name (car (cdr x)))) - (display "<option value=") - (display id) - (if (eq? (string->number id) selected-choice) - (display " selected")) - (display ">") - (display name) - (display "</option>"))) - (list-ref category 3)) - (display "</select>") - (display "</td><td>") - (join-widget (list-ref category 0) (number->string tabindex)) - (display "</td></tr>") - (set! tabindex (1+ tabindex)))) - (get-topic-list)) - - (display " -<tr> - <td colspan=\"3\" align=\"center\"> - <input type=\"submit\" name=\"search\" value=\"") - (display (_"Αναζήτηση")) - (display "\" tabindex=\"") - (display tabindex) - (display "\"> - </td> -</tr> -</table> -</form> -<p>"))) - -;; -(define (replace-tilde word sentence) - (apply - string-append - (let loop ((lst '()) - (str sentence)) - (cond - ((string-index str #\~) => - (lambda (x) - (loop - (append lst (list (substring str 0 x) word)) - (substring str (1+ x))))) - ((string-null? str) - lst) - (else - (append lst (list str))))))) - -;; -(define (display-results rlist) - (let ((x (car rlist))) - (display "<table class=\"noframe\">") - (display "<tr><td>") - (display (car x)) - (display "</td>") - (cond - ((list-ref x 3) - (display "<td>") - (let ((href (assoc (list-ref x 2) word-forms-reference))) - (cond - (href - (display "<a href=\"") - (cond - (ref-loc - (display ref-loc) - (display "/"))) - (display (language-code target-language)) - (display "/") - (display (cdr href)) - (display (dict:encode-string (car x))) - (display "\">") - (display (list-ref x 3)) - (display "</a>")) - (else - (display (list-ref x 3))))) - (display "</td>"))) - (display "<td>") - (display (list-ref x 2)) - (display "</td></tr>")) - (for-each - (lambda (x) - (display "<tr><td>") - (display (1+ (string->number (list-ref x 4)))) - (display "</td><td>") - (display (replace-tilde (car x) (list-ref x 5))) - (display ";</td></tr>")) - rlist) - (display "</table>") - (newline)) - -(define (display-cross-reference word) - (display "<a href=\"") - (display (make-cgi-name dict-cgi-path "IDENT" (dict:encode-string word))) - (display "\">") - (display word) - (display "</a>")) - -(define (display-xref rlist text) - (display text) - (let ((n 0)) - (for-each - (lambda (x) - (if (> n 0) - (display ", ")) - (set! n (1+ n)) - (display-cross-reference (car x))) - rlist)) - (display ";")) - -(define (sort-result input-list) - (let ((output-list '()) - (current-element '())) - (for-each - (lambda (x) - (cond - ((or (null? current-element) - (= (string->number (cadr x)) - (string->number (cadr (car current-element))))) - (set! current-element (cons x current-element))) - (else - (set! output-list (cons (reverse current-element) output-list)) - (set! current-element (list x))))) - input-list) - (cons (reverse current-element) output-list))) - - -(define (search-failure key) - (display "<h2>") - (format #t (_"Συγγνώμη, η λέξη \"~A\" δεν βρέθηκε στο λέξικο.") key) - (display "</h2>")) - -(define (my-sql-query conn query) - (catch #t - (lambda () - (sql-query conn query)) - (lambda args - '()))) - -(define (fuzzy-search conn key theme pos) - (let ((where-cond (list (string-append - "WHERE dict.ident=articles.ident and articles.lang='" - (language-code target-language) - "' AND"))) - (select-stmt "SELECT DISTINCT dict.word FROM ") - (from-list (list ",articles" "dict"))) - - (cond - ((not (null? theme)) - (set! where-cond (cons " topic_tab.word_ident=dict.ident" - where-cond)) - (set! from-list (cons ",topic_tab" from-list)))) - - (cond - ((not (string-null? key)) - (if (not (null? theme)) - (set! where-cond (cons " AND" where-cond))) - (set! where-cond (cons (string-append - " dict.sound LIKE \"" - (ellinika:sounds-like key) - "%\"") - where-cond)))) - - (cond - ((> (string->number pos) 0) - (let ((pos-entry - (list-ref part-of-speech (string->number pos)))) - (if (or (not (string-null? key)) (not (null? theme))) - (set! where-cond (cons - (if (string=? (cgi:value "joinpos") "0") - " AND" - " OR") - where-cond))) - - (set! where-cond (cons - (string-append " (dict.pos & " - (cdr pos-entry) - ") = " - (cdr pos-entry)) - where-cond))))) - - (let ((result - (my-sql-query conn - (string-append - select-stmt - - " " - - (apply - string-append - (reverse from-list)) - - " " - - (apply - string-append - (append - (reverse where-cond) - (map - (lambda (x) - (cond - ((boolean? x) - (if x " AND" " OR")) - (else - (if (not (member ",topic_tab" from-list)) - (set! from-list - (cons ",topic_tab" - from-list))) - (string-append - " topic_tab.topic_ident=" x)))) - theme))) - - " ORDER BY dict.word")))) - - (cond - ((null? result) - (search-failure key)) - (else - (display "<table width=\"100%\" class=\"noframe\">") - (let* ((result-length (length result)) - (lim (1+ (inexact->exact (/ result-length match-list-columns))))) - (do ((i 0 (1+ i))) - ((= i lim) #f) - (display "<tr>") - (do ((j i (+ j lim))) - ((>= j result-length) #f) - (display "<td>") - (display-cross-reference (car (list-ref result j))) - (display "</td>")) - (display "</tr>"))) - (display "</table>")))))) - - -(define (dict-search) - (let ((keyval (if (cgi:value "IDENT") - (dict:decode-string (cgi:value "IDENT")) - (cgi:value "key"))) - (theme (do ((catlist (get-topic-list) (cdr catlist)) - (ret '())) - ((null? catlist) ret) - (let ((name (caar catlist))) - (let ((v (cgi:value name))) - (if (and v (> (string->number v) 0)) - (set! ret (append - ret - (list (= (string->number - (cgi:value (string-append "join" name))) 0) - v)))))))) - (pos (or (cgi:value "POS") "0"))) - - (catch-sql-failure - (let ((conn (dict-connect))) - (cond - ((and keyval - (not (string-null? keyval)) - (null? theme) - (= (string->number pos) 0)) - (display "<hr>") - (let* ((key (ellinika:translate-input keyval)) - (result (my-sql-query - conn - (string-append - "SELECT dict.word,dict.ident,pos.abbr,dict.forms,articles.subindex,articles.meaning " - "FROM dict,articles,pos WHERE dict.word=\"" - key - "\" AND dict.ident=articles.ident " - "AND articles.lang='" (language-code target-language) "' " - "AND dict.pos=pos.id AND pos.canonical='Y' order by dict.ident, articles.subindex")))) - - (cond - ((null? result) - (fuzzy-search conn key theme pos)) - (else - (for-each - (lambda (entry) - (display-results entry) - (let ((ant (my-sql-query - conn - (string-append - "SELECT dict.word FROM dict,links WHERE links.type='ANT' AND links.ident=" - (cadr (car entry)) - " AND dict.ident=links.xref ORDER BY word")))) - (if (and ant (not (null? ant))) - (display-xref ant - (if (= (length ant) 1) - (_"Αντώνυμο: ") (_"Αντώνυμα: "))))) - (display "<p>") - (let ((x (my-sql-query - conn - (string-append - "SELECT dict.word FROM dict,links WHERE links.type='XREF' AND links.ident=" - (cadr (car entry)) - " AND dict.ident=links.xref ORDER BY word")))) - (if (and x (not (null? x))) - (display-xref x (_"Βλέπετε επίσης "))))) - (sort-result result)))))) - ((or (not (null? theme)) (> (string->number pos) 0)) - (display "<hr>") - (fuzzy-search conn - (ellinika:translate-input (or keyval "")) theme pos))))))) - -;;; - -(define (stat key) - (let ((stat-data #f)) - (if (not stat-data) - (set! stat-data - (or - (ignore-sql-failure - (my-sql-query (dict-connect) - (string-append - "SELECT count,updated from stat WHERE lang='" - (language-code target-language) - "'"))) - '()))) - - (if (null? stat-data) - "<>" - (case key - ((#:updated) - (list-ref (car stat-data) 1)) - ((#:count) - (list-ref (car stat-data) 0)) - (else - "<>"))))) - - -;;; - -(define (dict-html) - (let ((explist (list - (cons "@@args@@" - (lambda () - (for-each - (lambda (name) - (cond - ((string=? name "LANG")) - (else - (let ((v (cgi:value name))) - (cond ((and v (not (string-null? v))) - (display "&") - (display name) - (display "=") - (display v))))))) - (cgi:names)))) - (cons "@@dict@@" - (lambda () - (main-form) - (dict-search))) - (cons "@@stat_updated@@" - (lambda () - (display (stat #:updated)))) - (cons "@@stat_count@@" - (lambda () - (display - (let ((s (stat #:count))) - (if (string=? s "<>") - s - (let ((n (string->number s))) - (string-append s " " - (ngettext "λέξη" "λέξεις" - n))))))))))) - (do ((line (read-line) (read-line))) - ((eof-object? line) #f) - (expand-template explist line) - (newline)))) - -;;; Main -(display "Content-type: text/html; charset=utf-8\r\n\r\n") - -(with-input-from-file - (template-file target-language dict-template-file-name) - dict-html) - -(dict-connect #t) - -;;;; Local variables: -;;;; mode: Scheme -;;;; buffer-file-coding-system: utf-8 -;;;; End: - 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 @@ -#! =GUILE_BINDIR=/guile -s -=AUTOGENERATED= -!# -;;;; News page for Ellinika -;;;; Copyright (C) 2004, 2005, 2006 Sergey Poznyakoff -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2 of the License, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this program; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -;;;; - -;;; Tailor this statement to your needs if necessary. -;=GUILE_COMMENT=;(set! %load-path (cons "=GUILE_SITE=" %load-path)) - -(use-modules (www cgi) - (gamma sql) - (gamma gettext) - (xmltools dict) - (ellinika xlat) - (ellinika cgi)) -(cgi:init) - -(define tmpl (if (and monima-nea-template-file-name - (cgi:value "timestamp")) - monima-nea-template-file-name - nea-template-file-name)) - -(ellinika-cgi-init tmpl) - -(define conn #f) -(define article #f) -(define accepted-lang (map - (lambda (s) - (cond - ((string-split s #\;) => - (lambda (l) - (car l))) - (else - s))) - (string-split (or - (getenv "HTTP_ACCEPT_LANGUAGE") - "") - #\,))) - -(define nea-max-rows 20) ;; FIXME: Move to the config - -(define (permalink tag timestamp) - (display (string-append "<" tag " class=\"permalink\">")) - (display "<a href=\"") - (display (make-cgi-name nea-cgi-path "timestamp" timestamp)) - (display "\">[permanent link]</a>") - (display (string-append "</" tag ">"))) - -(define (sql-error-handler err descr) - (format #t "<h1 class=\"error\">~A</h1>\n" - (_ "ΣΦΆΛΜΑ: σύνδεση με την βάση δεδομένων απέτυχε.")) - (with-output-to-port - (current-error-port) - (lambda () - (display err) - (display ": ") - (display descr)))) - -(defmacro catch-sql (expr) - `(catch 'gsql-error - (lambda () ,expr) - (lambda (key err descr) - (sql-error-handler err descr)))) - -(defmacro assert-article (. expr) - `(if article - (cond - ((null? article) - (format #t "<h1 class=\"error\">~A</h1>\n" - (_ "Κάμια καταχώρηση"))) - (else - ,@expr)))) - -(define (make-sql-list input-list) - (let loop ((str "") - (input-list input-list)) - (if (null? input-list) - (string-append "(" str ")") - (loop (string-append str - (if (string-null? str) "'" ",'") - (car input-list) "'") - (cdr input-list))))) - -(define (get-sql-lang conn ident langlist) - (let ((res (map car (sql-query conn - (string-append - "SELECT lang " - "FROM newsart " - "WHERE ident=" ident " " - "AND lang in " (make-sql-list langlist)))))) - (cond - ((null? res) - #f) - (else - (call-with-current-continuation - (lambda (return) - (for-each - (lambda (elt) - (if (member elt res) - (return elt))) - langlist))))))) - -(define (make-my-lang-list) - (map language-code (cons target-language - accepted-lang))) - - -(define (collect-entries from fwd) - (let loop ((start from) - (result '())) - (cond - ((not fwd) - (set! start (- start nea-max-rows)) - (if (< start 0) - (set! start 0)))) - (call-with-current-continuation - (lambda (return) - (let ((tuples (sql-query - conn - (format #f - "SELECT date,ident FROM news ORDER BY 1 DESC LIMIT ~A,~A" - start nea-max-rows)))) - (cond - ((null? tuples) - (cons start (if fwd (reverse result) result))) - (else - (let ((langlist (make-my-lang-list)) - (rest (- nea-max-rows (length result))) - (ctr 0)) - (for-each - (lambda (entry) - (let ((lang (get-sql-lang conn (list-ref entry 1) langlist))) - (set! ctr (1+ ctr)) - (if lang - (let ((hdr (sql-query conn - (string-append - "SELECT header,lang " - "FROM newsart " - "WHERE ident=" (list-ref entry 1) " " - "AND lang='" lang "' " - "LIMIT 1")))) - (cond - (hdr - (set! result (cons - (cons (caar hdr) entry) - result)) - (set! rest (1- rest)) - (cond - ((= 0 rest) - (if fwd - (return (cons (+ ctr start) (reverse result))) - (return (cons (+ start (- nea-max-rows ctr)) - result))))))))))) - - (if fwd - tuples - (reverse tuples))) - - (cond - ((and (not fwd) (= 0 start)) - (cons start (if fwd (reverse result) result))) - (else - (if fwd - (set! start (+ ctr start))) - (loop start result))))))))))) - -(define (summary) - (catch-sql - (let* ((count (catch #t - (lambda () - (string->number - (caar (sql-query conn "SELECT count(*) FROM news")))) - (lambda args - 0))) - (from (catch #t - (lambda () - (let ((x (string->number (cgi:value "from")))) - (if (< x count) - x - 0))) - (lambda args - 0))) - (fwd (let ((dir (cgi:value "dir"))) - (or (not dir) - (string=? dir "1")))) - (entries (collect-entries from fwd))) - - (let ((start (car entries)) - (result (cdr entries))) - (cond - ((null? result) - (display "<div align=\"center\">") - (display (_ "Κανένα νέα")) - (display "</div>")) - (else - (let ((num-entries (length result)) - (begin (if fwd from start)) - (end (if fwd start from)) - (id (cgi:value "id"))) - - (cond - ((not (and (= from 0) (< num-entries nea-max-rows))) - (display "<p>") - (format #t (_ "Εγγραφείς ~A - ~A") begin end) - (display "</p>"))) - - (display "<table class=\"news-summary frame\">\n") - (let ((ctr 0) - (langlist (make-my-lang-list))) - (for-each - (lambda (entry) - (display "<tr class=\"") - (display (if (= (modulo ctr 2) 0) "even" "odd")) - (display "\">\n") - (set! ctr (1+ ctr)) - (display "<td class=\"date\">") - (display (list-ref entry 1)) - (display "</td>") - (display "<td class=\"subject") - (cond - ((and id (string=? (list-ref entry 2) id)) - (display " current\">") - (display (list-ref entry 0))) - (else - (display "\"><a href=\"") - (display (make-cgi-name nea-cgi-path - "id" (list-ref entry 2) - "from" (number->string begin))) - (display "\">") - (display (list-ref entry 0)) - (display "</a>"))) - (display "</td>") - (display "\n</tr>\n")) - result)) - (display "</table>") - - (display "<div class=\"menu-bar\" align=\"center\">") - (cond - ((> begin 0) - (display "<span class=\"menu-cell\"><a href=\"") - (display (apply make-cgi-name - nea-cgi-path - "from" (number->string begin) - "dir" "0" - (if id - (list "id" id) - '()))) - (display "\">") - (display (_ "Προηγούμενες")) - (display "</a></span>"))) - - (cond - ((< end count) - (display "<span class=\"menu-cell\"><a href=\"") - (display (apply make-cgi-name - nea-cgi-path - "from" (number->string end) - "dir" "1" - (if id - (list "id" id) - '()))) - (display "\">") - (display (_ "Ερχόμενες")) - (display "</a></span>"))) - (display "</div>")))))))) - -(define (display-article-header item) - (display "<div id=\"news-header\">") - (format #t "<span class=\"itemdate\">~A</span>\n" (car item)) - (display "<span class=\"itemsubject\">\n") - (display (list-ref item 2)) - (display "</span>") - (if (not (cgi:value "timestamp")) - (permalink "span" (list-ref item 1))) - (display "</div><!-- news-header -->")) - -(define (display-article-text item . rest) - (let ((class (and (not (null? rest)) (car rest)))) - (cond - (class - (display "\n<div class=\"") - (display class) - (display "\">\n") - (display (list-ref item 3)) - (display "</div>\n")) - (else - (display (list-ref item 3)))))) - -(define (main) - (catch-sql - (assert-article - (display-article-header article) - (display-article-text article "itemtext")))) - -(define (title) - (if article - (display (if (null? article) - (string-append - "<h1 class=\"error\">" - (_ "Κάμια καταχώρηση") - "</h1>") - (list-ref article 2))))) - - -(define (nea-html) - (let ((explist (list (cons "@@main@@" main) - (cons "@@summary@@" summary) - (cons "@@title@@" title) - (cons "@@article-text@@" - (lambda () - (catch-sql - (assert-article - (display-article-text article))))) - (cons "@@article-date@@" - (lambda () - (catch-sql - (assert-article - (display (car article)))))) - (cons "@@article-header@@" - (lambda () - (catch-sql - (assert-article - (display (list-ref article 2)))))) - (cons "@@full-header@@" - (lambda () - (catch-sql - (assert-article - (display-article-header - article))))) - (cons "@@args@@" - (lambda () - (for-each - (lambda (name) - (cond - ((string=? name "LANG")) - (else - (let ((v (cgi:value name))) - (cond ((and v (not (string-null? v))) - (display "&") - (display name) - (display "=") - (display v))))))) - (cgi:names))))))) - - (do ((line (read-line) (read-line))) - ((eof-object? line) #f) - (expand-template explist line) - (newline)))) - -(define (nea-rss-header) - (display "<?xml version=\"1.0\"?>\n") - (display "<rss version=\"2.0\"> - <channel> - <title>Τα νέα</title> - <description>Τα νέα</description> - <link>http://ellinika.gnu.org.ua</link>") - (format #t "<language>~A</language>" (language-code target-language)) - (display " - <generator>EllinikaNea</generator> - <copyright>2006 Sergey Poznyakoff</copyright> - <managingEditor>gray@gnu.org.ua</managingEditor> - <docs>http://blogs.law.harvard.edu/tech/rss</docs> -")) - -(define (nea-rss-footer) - (display " </channel> -</rss>")) - -(define (nea-sql-connect) - (let ((conn (sql-connect - sql-iface sql-host sql-port sql-database - sql-username sql-password))) - (sql-query conn "SET NAMES utf8") - conn)) - -(define (nea-rss) - (nea-rss-header) - (catch 'gsql-error - (lambda () - (let ((conn (nea-sql-connect))) - (for-each - (lambda (tuple) - (display "<item>\n") - (display "<pubDate>") - (display (list-ref tuple 0)) - (display "</pubDate>\n") - (display "<title>") - (let ((title (sql-query conn - (string-append - "SELECT header " - "FROM newsart " - "WHERE ident=" (list-ref tuple 2) " " - "AND lang='" - (get-sql-lang conn - (list-ref tuple 2) - (make-my-lang-list)) - "' " - "LIMIT 1")))) - (display (if (not (null? title)) - (caar title) - (list-ref tuple 0)))) - (display "</title>\n") - (display "<link>") - (display (string-append - (string-downcase cgi-server-protocol-name) - "://" - cgi-server-hostname - "/" - (make-cgi-name nea-cgi-path "timestamp" (list-ref tuple 1)))) - (display "</link>\n") - (display "</item>\n")) - (sql-query - conn - (string-append - "SELECT date,unix_timestamp(date),ident " - "FROM news " - "ORDER BY 1 DESC LIMIT 10"))))) - (lambda (key err descr) - (sql-error-handler err descr))) - (nea-rss-footer)) - - -(define (get-article-by-timestamp ts) - (let ((tuples (sql-query - conn - "SELECT date,unix_timestamp(date),ident FROM news WHERE unix_timestamp(date)=" ts))) - (cond - (tuples - (let* ((res (car tuples)) - (lang (get-sql-lang conn (list-ref res 2) (make-my-lang-list))) - (art (sql-query conn - (string-append - "SELECT header,text,lang " - "FROM newsart " - "WHERE ident=" (list-ref res 2) " " - "AND lang='" lang "' " - "LIMIT 1")))) - (append - (list (list-ref res 0) - (list-ref res 1)) - (car art))))))) - - -;;; Main - -(cond - ((cgi:value "rss") - (display "Content-type: text/xml; charset=utf-8\r\n\r\n") - (nea-rss)) - (else - (catch 'gsql-error - (lambda () - (display "Content-type: text/html; charset=utf-8\r\n\r\n") - (set! conn (nea-sql-connect)) - (cond - ((or (cgi:value "timestamp") (cgi:value "id")) - (let ((tuples (sql-query - conn - (string-append - "SELECT date,unix_timestamp(date),ident " - "FROM news " - "WHERE " - (cond - ((cgi:value "timestamp") => - (lambda (ts) - (string-append "unix_timestamp(date)=" ts))) - ((cgi:value "id") => - (lambda (id) - (string-append "ident=" id)))))))) - - (if (not (null? tuples)) - (let* ((res (car tuples)) - (lang (get-sql-lang conn - (list-ref res 2) - (make-my-lang-list))) - (art (sql-query - conn - (string-append - "SELECT header,text,lang " - "FROM newsart " - "WHERE ident=" (list-ref res 2) " " - "AND lang='" lang "' " - "LIMIT 1")))) - (set! article (append - (list (list-ref res 0) - (list-ref res 1)) - (car art)))))))) - - (with-input-from-file - (template-file target-language tmpl) - nea-html) - - (sql-connect-close conn)) - - (lambda (key err descr) - (with-input-from-file - (template-file target-language tmpl) - (lambda () - (let ((explist - (list (cons "@@main@@" - (lambda () - (sql-error-handler err descr))) - (cons "@@article-text@@" - (lambda () - (sql-error-handler err descr))) - (cons "@@summary@@" (lambda () #f)) - (cons "@@title@@" (lambda () #f)) - (cons "@@article-date@@" (lambda () #f)) - (cons "@@article-header@@" (lambda () #f)) |