diff options
-rw-r--r-- | cgi-bin/dict.scm4 | 621 | ||||
-rw-r--r-- | cgi-bin/nea.scm4 | 536 | ||||
-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 --- /dev/null +++ b/cgi-bin/dict.scm4 @@ -0,0 +1,621 @@ +;;;; Greek Dictionary Web Engine +;;;; 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. +(set! %load-path (cons "GUILE_SITE" %load-path)) + +(use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user)) + (ice-9 rdelim) + (gamma sql) + (gamma gettext) + (xmltools dict) + (ellinika xlat) + (ellinika cgi)) + +ifelse(IFACE,[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 cgi-script-name)) + (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 cgi-script-name "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 +ifelse(IFACE,[CGI],(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.scm4 b/cgi-bin/nea.scm4 new file mode 100644 index 0000000..20e1803 --- /dev/null +++ b/cgi-bin/nea.scm4 @@ -0,0 +1,536 @@ +;;;; 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. +(set! %load-path (cons "GUILE_SITE" %load-path)) + +(use-modules ifelse(IFACE,[CGI],(www cgi),(guile-user)) + (gamma sql) + (gamma gettext) + (xmltools dict) + (ellinika xlat) + (ellinika cgi)) + +ifelse(IFACE,[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 cgi-script-name "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 cgi-script-name + "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 + cgi-script-name + "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 + cgi-script-name + "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 cgi-script-name + "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") + ifelse(IFACE,[CGI], + (display ["Content-type: text/xml; charset=utf-8\r\n\r\n"]), + (request-rec:set-content-type! Request ["text/xml; charset=UTF-8"])) + (nea-rss)) + (else + (catch 'gsql-error + (lambda () + ifelse(IFACE,[CGI],dnl + (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)) + (cons "@@full-header@@" (lambda () #f))))) + (do ((line (read-line) (read-line))) + ((eof-object? line) #f) + (expand-template explist line) + (newline))))))))) + +;;;; Local variables: +;;;; mode: Scheme +;;;; buffer-file-coding-system: utf-8 +;;;; End: diff --git a/ellinika/cgi.scmi b/ellinika/cgi.scm4 index b4da8f9..dc7c05d 100644 --- a/ellinika/cgi.scmi +++ b/ellinika/cgi.scm4 @@ -1,5 +1,4 @@ ;;;; -*- scheme -*- -=AUTOGENERATED= |