Switch to a more sensible error reporting system

1 files changed, 92 insertions, 0 deletions

diff --git a/src/scm/webid-oidc/web-i18n.scm b/src/scm/webid-oidc/web-i18n.scm
new file mode 100644
index 0000000..d3a773f
--- /dev/null
+++ b/src/scm/webid-oidc/web-i18n.scm
@@ -0,0 +1,92 @@
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 2020, 2021  Vivien Kraus
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 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 Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (webid-oidc web-i18n)
+  #:use-module (ice-9 i18n)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-26)
+  #:use-module (web request)
+  #:declarative? #t
+  #:export
+  (
+
+   web-locale
+   
+   (web-gettext . W_)
+   (sysadmin-gettext . G_)
+
+   ))
+
+(define locale-mutex
+  (make-mutex))
+
+(define sort-qlist
+  (cute sort <>
+        (match-lambda*
+          (((px . _) (py . _))
+           (>= px py)))))
+
+(define get-preferred-language
+  (match-lambda
+    ((? request?
+        (= request-accept-language
+           (= sort-qlist
+              (((_ . language) _ ...)))))
+     (get-preferred-language language))
+    ((? string?
+        (= (cute string-split <> #\-)
+           ((? string? lang)
+            (? string? region))))
+     (format #f "~a_~a.UTF-8" lang region))
+    (else "")))
+
+(define web-locale
+  (make-parameter
+   "en-US"
+   get-preferred-language))
+
+(define (disambiguate str out)
+  (if (string=? out str)
+      ;; No translation, disambiguate
+      (car (reverse (string-split str #\|)))
+      ;; Translation done, nothing to do
+      out))
+
+(define (web-gettext str)
+  (let ((out
+         (with-mutex locale-mutex
+           (let ((previous-locale (setlocale LC_ALL)))
+             (dynamic-wind
+               (lambda ()
+                 (with-exception-handler
+                     (lambda (exn)
+                       (setlocale LC_ALL "C"))
+                   (lambda ()
+                     (setlocale LC_ALL (web-locale)))
+                   #:unwind? #t))
+               (lambda ()
+                 (gettext str))
+               (lambda ()
+                 (setlocale LC_ALL previous-locale)))))))
+    (disambiguate str out)))
+
+(define (sysadmin-gettext str)
+  (let ((out
+         (with-mutex locale-mutex
+           (gettext str))))
+    (disambiguate str out)))