source: project/release/3/svnwiki-translations/trunk/svnwiki-translations.scm @ 18181

Last change on this file since 18181 was 18181, checked in by azul, 11 years ago

Lots of additional functionality.

  • Property svn:keywords set to id
File size: 17.6 KB
Line 
1; $id$
2;
3; License: GPL-3
4
5(declare (export))
6(use content-type format-modular html-stream iconv orders posix srfi-1 srfi-40 stream-base64 stream-ext svn-client svnwiki-extensions-support url embedded-test)
7
8(define *languages*
9  '((es "Español")
10    (en "English")
11    (fr "Français")
12    (pt "Português")))
13
14(define (translations-links env)
15  (let-from-environment env (path-out-real path-in params)
16    (let* ((components (string-split path-out-real "/"))
17           (special (svnwiki-is-special? #f path-out-real))
18           (base-filename
19             (string-append
20               (stream->string (svnwiki-file-without-language (last components)))
21               "."))
22           (dir
23             (svnwiki-make-pathname
24               (cons path-in
25                     ((if special butlast identity)
26                      (butlast components)))))
27           (translations
28             (stream-filter
29               (lambda (file)
30                 (and (> (string-length file) (string-length base-filename))
31                      (substring=? base-filename file)
32                      (or (not (string=? file path-out-real))
33                          special)))
34               (if (directory? dir)
35                 (list->stream (directory dir))
36                 stream-null)))
37           (charset (svnwiki-encoding-for-file env))
38           (charset-convert
39             (if (string=? charset "utf-8")
40               identity
41               (let ((descriptor (iconv-open charset "utf-8")))
42                 (cut iconv descriptor <>)))))
43      (if (stream-null? translations)
44        (html-stream
45          (p (cdr (or (assoc 'none params) (cons #f (html-stream "No translations are available for this file."))))))
46        (html-stream
47          (ul
48            (stream-concatenate
49              (stream-map
50                (lambda (file)
51                  (html-stream
52                    ((li class "translationLink")
53                     ((a href
54                         (svnwiki-make-pathname
55                           (and special "..")
56                           file
57                           (mime->ending
58                             ((handler-mime (get-handler (environment env ((path path-out-real)))))
59                              path-in
60                              path-out-real))))
61                      (let* ((language (svnwiki-file-language file))
62                             (name (and language (assoc (stream->symbol language) *languages*))))
63                        (if name
64                          (charset-convert (cadr name))
65                          language))))))
66                translations))))))))
67
68(svnwiki-extension-define 'code-break 'translations translations-links)
69
70;;; Database handling
71
72(define *translations-db* #f)
73
74(define (translations-db-run env query . params)
75  (let-from-environment env (data)
76    (unless *translations-db*
77      (let* ((db-path (svnwiki-make-pathname data "translations" "db"))
78             (existed (file-exists? db-path)))
79        (format (current-error-port) "Opening DB: ~A~%" db-path)
80        (set! *translations-db* (sqlite3:open db-path))
81        (unless existed
82          (format (current-error-port) "Creating initial tables in DB: ~A~%" db-path)
83          (translations-db-create env))))
84    (let ((result
85            (iterator->stream
86              (lambda (capture stop)
87                (receive (stmt rest)
88                         (sqlite3:prepare *translations-db* query)
89                  (apply (stream-wrap-proc-string sqlite3:for-each-row) (compose capture vector) stmt params)
90                  (sqlite3:finalize! stmt))))))
91      (stream-length result) ; force execution
92      result)))
93
94(define (translations-db-create env)
95  (translations-db-run env "CREATE TABLE dependencies ( path varchar, string varchar );")
96  (translations-db-run env "CREATE TABLE translations ( path varchar, source varchar, destination varchar );"))
97
98;;; Translating strings
99
100(define (string-canonical str)
101  (stream-drop-while
102    char-whitespace?
103    (stream-fold-right-delay
104      (lambda (c rest)
105        (cond
106          ((not (char-whitespace? c))
107           (stream-cons c rest))
108          ((or (stream-null? rest)
109               (char-whitespace? (stream-car rest)))
110           rest)
111          (else (stream-cons #\space rest))))
112      stream-null
113      (if (string? str) (string->stream str) str))))
114
115(test-group string-canonical
116  (test (stream->string (string-canonical (string->stream "  hey\nthere    you  \n  boy   ")))
117        "hey there you boy"))
118
119(define (get-trans env src)
120  (let-from-environment env (translations-path)
121    (let ((dst (translations-db-run env "SELECT destination FROM translations WHERE path = ? AND source = ?;" translations-path (string-canonical src))))
122      (and (not (stream-null? dst))
123           (string->stream (vector-ref (stream-car dst) 0))))))
124
125(define (translate-str env text)
126  (let-from-environment env (path-in path)
127    (when (stream-null? (translations-db-run env "SELECT path FROM dependencies WHERE path = ? AND string = ?;" path (string-canonical text)))
128      (translations-db-run env "INSERT INTO dependencies VALUES ( ?, ? );" path (string-canonical text)))
129    (let ((trans (get-trans env text)))
130      (html-stream
131        (format "<translation original='~A' translated=~A>" (url-encode (stream->string text)) (if trans "true" "false"))
132        (or trans text)
133        "</translation>"))))
134
135(define (translation env)
136  (let-from-environment env (text parse-paragraph path path-in translations-path params)
137    (let ((container (format #f "untranslated-~A" (random 1000000)))
138          (original (cdr (or (assoc 'original params) (cons #f text))))
139          (translated (stream= char=? (cdr (or (assoc 'translated params) (cons #f stream-null))) (string->stream "true"))))
140      (html-stream
141        ((span class (if translated "translationdone" "translation") id container)
142         (parse-paragraph text)
143         ((span class "translatelink")
144          " ["
145          ((a href (format #f "~A~A?action=edit&section=~A&create=true"
146                           (get-props-parents-first "svnwiki:application-url:http" path-in path #f)
147                           translations-path
148                           (stream->string (string-canonical original)))
149              onclick (format #f "if (typeof(svnwikiInlineEdit) == 'object') { return !svnwikiInlineEdit.loadForm('~A', '~A', '~A', true); } return true;"
150                              (url-encode container)
151                              (stream->string (string-canonical original))
152                              (url-encode translations-path (list #\. #\/))))
153           (if translated
154             "Edit translation"
155             "Add translation"))
156          "]"))))))
157
158(svnwiki-extension-define 'code-span 'translation translation)
159
160;;; Generating translated files
161
162(define (find-translations-path env . rest)
163  (let-from-environment env (path-in path)
164    (let-optionals rest ((my-directory? directory?))
165      (let loop ((path path))
166        (if (my-directory? (svnwiki-make-pathname (list path-in path) "xsvnwiki-translations"))
167          path
168          (and (not (string=? path ""))
169               (loop (svnwiki-dirname path))))))))
170
171(test-group find-translations-path
172  (test (find-translations-path (environment ((path-in "/path-in") (path "foo/bar/hey")))
173                                (lambda (str)
174                                  (string=? str "/path-in/xsvnwiki-translations")))
175        "")
176
177  (test (find-translations-path (environment ((path-in "/path-in") (path "foo/bar/hey")))
178                                (lambda (str)
179                                  (or (string=? str "/path-in/foo/bar/xsvnwiki-translations")
180                                      (string=? str "/path-in/xsvnwiki-translations"))))
181        "foo/bar"))
182
183
184(define (translatable? env)
185  (let-from-environment env (path)
186    (not (or (directory? (svnwiki-repository-path env))
187             (string=? (svnwiki-basename (svnwiki-dirname path)) "xsvnwiki-translations")
188             (svnwiki-file-language path)
189             (get-props-parents-first-boolean env "svnwiki:translations:ignore" #f)
190             (not (svnwiki-render-file-contents (environment env ((path-out-real path)))))))))
191
192(define (translations-update env)
193  (let-from-environment env (path-in path path-out)
194    (when (translatable? env)
195      (let* ((translations-path (find-translations-path env))
196             (languages (list->stream (directory (svnwiki-make-pathname (list path-in translations-path) "xsvnwiki-translations")))))
197        (when translations-path
198          (stream-for-each
199            (lambda (lang)
200              (svnwiki-report-progress env (svnwiki-translate env "Generating translation to ~A for: ~A~%") lang path)
201              (translations-db-run env "DELETE FROM dependencies WHERE path = ?;" path)
202              (let ((content-type (render-file-mime-type env))
203                    (path-out-real (format #f "~A.~A" path lang)))
204                (write-file-with-tmp path-out-real content-type path-out
205                  (render-file
206                    (environment env ((path-out-real path-out-real)
207                                      (translations-path (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang))
208                                      (translate
209                                        (cut translate-str
210                                             (environment env
211                                               ((translations-path (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang))))
212                                             <...>))))
213                    'view))))
214            languages)
215          (render-translations-status env translations-path languages))))))
216
217(svnwiki-extension-define 'update-notify-recursive 'translations translations-update)
218
219;;; Status of translations
220
221(define (render-translations-status env translations-path languages)
222  (let-from-environment env (path-in path path-out)
223    (svnwiki-report-progress env (svnwiki-translate env "Generating report of translations status for: ~A~%") path)
224    (let ((path-out-real (svnwiki-make-pathname (list (svnwiki-dirname path) "xsvnwiki-translations-status") (svnwiki-basename path))))
225      (write-file-with-tmp path-out-real "text/html" path-out
226        (render-template
227          (environment env ((path-out-real path-out-real)))
228          "Translations: "
229          (html-stream
230            (p "The following is the translation status for this file:")
231            (table
232              (tr
233                (td "Original")
234                (stream-concatenate
235                  (stream-map
236                    (lambda (lang)
237                      (html-stream
238                        (td
239                          ((a href (make-link-url path-out-real (svnwiki-make-pathname #f path lang) #f)) lang)
240                          " ["
241                          ((a href (make-link-url path-out-real (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang) #f)) "catalog")
242                          "]")))
243                    languages)))
244              (stream-concatenate
245                (stream-map
246                  (lambda (str)
247                    (html-stream
248                      (tr
249                        (td (vector-ref str 0))
250                        (stream-concatenate
251                          (stream-map
252                            (lambda (lang)
253                              (html-stream
254                                (td
255                                  (let ((text (translations-db-run env "SELECT destination FROM translations WHERE path = ? AND source = ?;"
256                                                                   (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang)
257                                                                   (string-canonical (vector-ref str 0)))))
258                                    (if (stream-null? text)
259                                      "Missing"
260                                      (svnwiki-stream-cut-with-ellipsis (vector-ref (stream-car text) 0) 40)))
261                                  " ["
262                                  ((a href (format #f "~A~A?action=edit&section=~A&create=true"
263                                                   (get-props-parents-first "svnwiki:application-url:http" path-in path #f)
264                                                   (svnwiki-make-pathname (list translations-path "xsvnwiki-translations") lang)
265                                                   (stream->string (string-canonical (vector-ref str 0)))))
266                                   "Edit")
267                                  "]")))
268                            languages)))))
269                  (translations-db-run env "SELECT string FROM dependencies WHERE path = ?;" path)))))
270          'view)))))
271
272(define (translations-actions-links env)
273  (when (translatable? env)
274    (let-from-environment env (path path-out-real)
275      (unless (string=? (svnwiki-basename (svnwiki-dirname path-out-real))
276                        "xsvnwiki-translations-status")
277        (svnwiki-file-action-link
278          env
279          (svnwiki-make-pathname "xsvnwiki-translations-status" (svnwiki-basename path))
280          "Translations")))))
281
282(svnwiki-extension-define 'files-actions-links 'translations translations-actions-links)
283
284;;; Updating lists of translations
285
286; Return a stream of elements of the form (src dst), where both src and dst are
287; streams of characters.  Each corresponds to one translation of the string
288; 'src' to the string 'dst' found in the file specified (by path-in and path).
289
290(define (get-translations-from-file env)
291  (let-from-environment env (path-in path)
292    (wiki-translations (wiki-open path-in path))))
293
294(define (translations-update-catalog env)
295  (let-from-environment env (path-in path path-out regenerate-page)
296    (when (string=? (svnwiki-basename (svnwiki-dirname path)) "xsvnwiki-translations")
297      (svnwiki-report-progress env (svnwiki-translate env "Updating cache of translations: ~A~%") path)
298      (let ((new-translations (get-translations-from-file env)))
299        ; Regenerate pages that depend on translations that changed:
300        (stream-for-each
301          (lambda (data)
302            (let ((old (get-trans (environment env ((translations-path path))) (car data))))
303              (unless (and old (stream= char=? old (cadr data)))
304                (stream-for-each
305                  (compose regenerate-page (cut vector-ref <> 0))
306                  (translations-db-run env "SELECT path FROM dependencies WHERE string = ?;" (string-canonical (car data)))))))
307          new-translations)
308        ; Remove old translations
309        (translations-db-run env "DELETE FROM translations WHERE path = ?;" path)
310        ; Store new translations
311        (stream-for-each
312          (lambda (data)
313            (translations-db-run env "INSERT INTO translations VALUES ( ?, ?, ? );" path (string-canonical (car data)) (cadr data)))
314          new-translations)))))
315
316(svnwiki-extension-define 'update-notify-recursive-meta 'translations translations-update-catalog)
317
318;;; List of dependencies on translations
319
320(define (translations-footer env)
321  (let-from-environment env (path-in path return name path-out-real)
322    (when (string=? (svnwiki-basename (svnwiki-dirname path)) "xsvnwiki-translations")
323      (let ((deps (translations-db-run env "SELECT path FROM dependencies WHERE string = ?;" (string-canonical name))))
324        (return
325          (if (stream-null? deps)
326            (html-stream (p "No pages depend on this translation."))
327            (html-stream
328              (p "The following pages depend on this translation:")
329              (stream->html-ul
330                (stream-map
331                  (lambda (data)
332                    (svnwiki-get-title-html (environment env ((path (vector-ref data 0))))))
333                  deps)))))))))
334
335(svnwiki-extension-define 'section-footer 'translations translations-footer)
336
337(define (translations-catalog? env)
338  (let-from-environment env (path)
339    (string=? (svnwiki-basename (svnwiki-dirname path)) "xsvnwiki-translations")))
340
341(test-group translations-catalog?
342  (test (translations-catalog? (environment ((path "foo/xsvnwiki-translations/en")))))
343  (test (translations-catalog? (environment ((path "xsvnwiki-translations/en")))))
344  (test (not (translations-catalog? (environment ((path "foo/xsvnwiki-translations"))))))
345  (test (not (translations-catalog? (environment ((path "foo/bar")))))))
346
347(define (edit-form-instructions env)
348  (when (translations-catalog? env)
349    (let-from-environment env (path return user-input)
350      (return
351        (let ((section (user-input 'section stream-null)))
352          (if (stream-null? section)
353            (html-stream
354              (p "You are editing a catalog of translations to " (tt (svnwiki-basename path)) 
355                 " ("
356                 (cadr (or (assoc (string->symbol (svnwiki-basename path)) *languages*) (list #f "Unknown")))
357                 "):"))
358            (html-stream
359              (p "You are editing the " (tt (svnwiki-basename path)) 
360                 " ("
361                 (cadr (or (assoc (string->symbol (svnwiki-basename path)) *languages*) (list #f "Unknown")))
362                 ")"
363                 " translation for the string:")
364              (blockquote (i section)))))))))
365
366(svnwiki-extension-define 'edit-form-instructions 'translations edit-form-instructions)
367
368(define (translations-hide-title env)
369  (when (translations-catalog? env)
370    (let-from-environment env (return)
371      (return #t))))
372
373(svnwiki-extension-define 'edit-form-section-title-hide 'translations translations-hide-title)
374
375(define (body-default env)
376  (when (translations-catalog? env)
377    (let-from-environment env (return section)
378      (return (html-stream "== " section "\n\n" section)))))
379
380(svnwiki-extension-define 'edit-form-section-body-default 'translations body-default)
Note: See TracBrowser for help on using the repository browser.