Replace thread-let with thread-utils

lib/syntax.rkt

@@ -4,8 +4,6 @@
 (provide
  ; help make a nested if. if/in will gain the same false form of its containing if/out.
  if/out
- ; let, but the value for each variable is evaluated within a thread
- thread-let
  ; cond, but values can be defined between conditions
  cond/var
  ; wrap sql statements into lambdas so they can be executed during migration
@@ -25,7 +23,6 @@
 
   (provide
    transform-if/out
-   transform-thread-let
    transform/out-cond/var)
 
   (define (transform-if/out stx)
@@ -51,26 +48,6 @@
           [#t node])))
     (datum->syntax stx (cons 'if result)))
 
-  (define (transform-thread-let stx)
-    (define tree (cdr (syntax->datum stx)))
-    (define defs (car tree))
-    (define forms (cdr tree))
-    (when (eq? (length forms) 0)
-      (error (format "thread-let: bad syntax (need some forms to execute after the threads)~n  forms: ~a" forms)))
-    (define counter (build-list (length defs) values))
-    (datum->syntax
-     stx
-     `(let ([chv (build-vector ,(length defs) (λ (_) (make-channel)))])
-        ,@(map (λ (n)
-                 (define def (list-ref defs n))
-                 `(thread (λ () (channel-put (vector-ref chv ,n) (let _ () ,@(cdr def))))))
-               counter)
-        (let ,(map (λ (n)
-                     (define def (list-ref defs n))
-                     `(,(car def) (channel-get (vector-ref chv ,n))))
-                   counter)
-          ,@forms))))
-
   (define (transform/out-cond/var stx)
     (define tree (transform-cond/var (cdr (syntax->datum stx))))
     (datum->syntax
@@ -119,35 +96,6 @@
   (check-equal? (if/out #t (if/in #f 'yes) 'no) 'no)
   (check-equal? (if/out #f (if/in #f 'yes) 'no) 'no))
 
-(define-syntax (thread-let stx)
-  (transform-thread-let stx))
-(module+ test
-  ; check that it is transformed as expected
-  (check-syntax-equal?
-   (transform-thread-let
-    #'(thread-let ([a (hey "this is a")]
-                   [b (hey "this is b")])
-                  (list a b)))
-   #'(let ([chv (build-vector 2 (λ (_) (make-channel)))])
-       (thread (λ () (channel-put (vector-ref chv 0) (let _ () (hey "this is a")))))
-       (thread (λ () (channel-put (vector-ref chv 1) (let _ () (hey "this is b")))))
-       (let ([a (channel-get (vector-ref chv 0))]
-             [b (channel-get (vector-ref chv 1))])
-         (list a b))))
-  ; check that they actually execute concurrently
-  (define ch (make-channel))
-  (check-equal? (thread-let ([a (begin
-                                  (channel-put ch 'a)
-                                  (channel-get ch))]
-                             [b (begin0
-                                    (channel-get ch)
-                                  (channel-put ch 'b))])
-                            (list a b))
-                '(b a))
-  ; check that it assigns the correct value to the correct variable
-  (check-equal? (thread-let ([a (sleep 0) 'a] [b 'b]) (list a b))
-                '(a b)))
-
 (define-syntax (cond/var stx)
   (transform/out-cond/var stx))
 (module+ test

lib/thread-utils.rkt

@@ -0,0 +1,72 @@
+#lang racket/base
+(require (prefix-in easy: net/http-easy)
+         "../src/data.rkt"
+         "xexpr-utils.rkt")
+
+(provide
+ thread-values)
+
+(module+ test
+  (require rackunit))
+
+(define (thread-values . thunks)
+  (parameterize-break #t
+    (define the-exn (box #f))
+    (define original-thread (current-thread))
+    (define (break e)
+      (when (box-cas! the-exn #f e)
+        (break-thread original-thread))
+      (sleep 0))
+    (define-values (threads channels)
+      (for/fold ([ts null]
+                 [chs null]
+                 #:result (values (reverse ts) (reverse chs)))
+                ([th thunks])
+        (define ch (make-channel))
+        (define t
+          (thread (λ ()
+                    (with-handlers ([exn? break])
+                      (channel-put ch (th))))))
+        (values (cons t ts) (cons ch chs))))
+    (apply
+     values
+     (with-handlers ([exn:break? (λ (_)
+                                   (for ([t threads]) (kill-thread t))
+                                   (if (unbox the-exn)
+                                       (raise (unbox the-exn))
+                                       (error 'thread-values "a thread broke, but without reporting its exception")))])
+       (for/list ([ch channels])
+         (channel-get ch))))))
+
+(module+ test
+  ; check that they actually execute concurrently
+  (define ch (make-channel))
+  (check-equal? (let-values ([(a b)
+                              (thread-values
+                               (λ ()
+                                 (begin
+                                   (channel-put ch 'a)
+                                   (channel-get ch)))
+                               (λ ()
+                                 (begin0
+                                     (channel-get ch)
+                                   (channel-put ch 'b))))])
+                  (list a b))
+                '(b a))
+  ; check that it assigns the correct value to the correct variable
+  (check-equal? (let-values ([(a b)
+                              (thread-values
+                               (λ () (sleep 0) 'a)
+                               (λ () 'b))])
+                  (list a b))
+                '(a b))
+  ; check that exceptions are passed to the original thread, and other threads are killed
+  ;; TODO: if the other thread was making an HTTP request, could it be left stuck open by the kill?
+  (check-equal? (let* ([x "!"]
+                       [res
+                        (with-handlers ([exn:fail:user? (λ (e) (exn-message e))])
+                          (thread-values
+                           (λ () (sleep 0) (set! x "?") (println "this side effect should not happen"))
+                           (λ () (raise-user-error "catch me"))))])
+                  (string-append res x))
+                "catch me!"))

lib/tree-updater.rkt

@@ -277,8 +277,8 @@
   ; check that noscript images are removed
   (check-equal? ((query-selector (λ (t a c) (eq? t 'noscript)) transformed)) #f)
   ; benchmark
-  (when (file-exists? "../misc/Frog.html")
+  (when (file-exists? "../storage/Frog.html")
-    (with-input-from-file "../misc/Frog.html"
+    (with-input-from-file "../storage/Frog.html"
       (λ ()
         (define tree (html->xexp (current-input-port)))
         (time (length (update-tree-wiki tree "minecraft")))))))

src/application-globals.rkt

@@ -201,13 +201,16 @@
            ,(if (config-true? 'instance_is_official)
                 (let ([balloon '(img (@ (src "/static/three-balloons.png") (class "bw-balloon") (title "Image Source: pngimg.com/image/4955 | License: CC BY-NC 4.0 | Modifications: Resized") (width "52") (height "56")))]
                       [extension-eligible?
-                       (and req (let* ([ua-pair (assq 'user-agent (request-headers req))]
+                       (cond/var
-                                       [ua (string-downcase (cdr ua-pair))])
+                        [(not req) #f]
+                        (var ua-pair (assq 'user-agent (request-headers req)))
+                        [(not ua-pair) #f]
+                        (var ua (string-downcase (cdr ua-pair)))
                         ;; everyone pretends to be chrome, so we do it in reverse
                         ;; this excludes common browsers that don't support the extension
-                                  (and (not (string-contains? ua "edge/"))
+                        [#t (and (not (string-contains? ua "edge/"))
                                  (not (string-contains? ua "edg/"))
-                                       (not (string-contains? ua "mobile")))))])
+                                 (not (string-contains? ua "mobile")))])])
                   `(div (@ (class "bw-top-banner"))
                         ,balloon
                         (div

src/extwiki-generic.rkt

@@ -28,7 +28,7 @@
     (hash-set! wikis-hash (symbol->string wikiname) w)))
 (module+ test
   (check-equal? (cadr (hash-ref wikis-hash "gallowmere"))
-                "Gallowmere Historia"))
+                "MediEvil Wiki"))
 
 (define (parse-table table)
   (define rows (query-selector (λ (t a c) (eq? t 'tr)) table))

src/page-category.rkt

@@ -17,6 +17,7 @@
          "data.rkt"
          "page-wiki.rkt"
          "../lib/syntax.rkt"
+         "../lib/thread-utils.rkt"
          "../lib/url-utils.rkt"
          "whole-utils.rkt"
          "../lib/xexpr-utils.rkt")
@@ -69,8 +70,10 @@
    (define origin (format "https://~a.fandom.com" wikiname))
    (define source-url (format "~a/wiki/~a" origin prefixed-category))
 
-   (thread-let
+   (define-values (members-data page-data siteinfo)
-    ([members-data (define dest-url
+     (thread-values
+      (λ ()
+        (define dest-url
           (format "~a/api.php?~a"
                   origin
                   (params->query `(("action" . "query")
@@ -81,8 +84,9 @@
                                    ("format" . "json")))))
         (log-outgoing dest-url)
         (define dest-res (easy:get dest-url #:timeouts timeouts))
-                   (easy:response-json dest-res)]
+        (easy:response-json dest-res))
-     [page-data (define dest-url
+      (λ ()
+        (define dest-url
           (format "~a/api.php?~a"
                   origin
                   (params->query `(("action" . "parse")
@@ -92,8 +96,9 @@
                                    ("format" . "json")))))
         (log-outgoing dest-url)
         (define dest-res (easy:get dest-url #:timeouts timeouts))
-                (easy:response-json dest-res)]
+        (easy:response-json dest-res))
-     [siteinfo (siteinfo-fetch wikiname)])
+      (λ ()
+        (siteinfo-fetch wikiname))))
 
    (define title (preprocess-html-wiki (jp "/parse/title" page-data prefixed-category)))
    (define page-html (preprocess-html-wiki (jp "/parse/text" page-data "")))
@@ -117,7 +122,7 @@
     #:code 200
     #:headers (build-headers always-headers)
     (λ (out)
-       (write-html body out))))))
+      (write-html body out)))))
 (module+ test
   (check-not-false ((query-selector (attribute-selector 'href "/test/wiki/Ankle_Monitor")
                                     (generate-results-page

src/page-file.rkt

@@ -17,6 +17,7 @@
          "data.rkt"
          "page-wiki.rkt"
          "../lib/syntax.rkt"
+         "../lib/thread-utils.rkt"
          "../lib/url-utils.rkt"
          "whole-utils.rkt"
          "../lib/xexpr-utils.rkt")
@@ -108,8 +109,10 @@
    (define origin (format "https://~a.fandom.com" wikiname))
    (define source-url (format "~a/wiki/~a" origin prefixed-title))
 
-   (thread-let
+   (define-values (media-detail siteinfo)
-    ([media-detail (define dest-url
+     (thread-values
+      (λ ()
+        (define dest-url
           (format "~a/wikia.php?~a"
                   origin
                   (params->query `(("format" . "json") ("controller" . "Lightbox")
@@ -117,8 +120,9 @@
                                                        ("fileTitle" . ,prefixed-title)))))
         (log-outgoing dest-url)
         (define dest-res (easy:get dest-url #:timeouts timeouts))
-                   (easy:response-json dest-res)]
+        (easy:response-json dest-res))
-     [siteinfo (siteinfo-fetch wikiname)])
+      (λ ()
+        (siteinfo-fetch wikiname))))
    (if (not (jp "/exists" media-detail #f))
        (next-dispatcher)
        (response-handler
@@ -143,7 +147,7 @@
           (xexp->html body))
         (response/output #:code 200
                          #:headers (build-headers always-headers)
-                          (λ (out) (write-html body out))))))))
+                         (λ (out) (write-html body out)))))))
 (module+ test
   (parameterize ([(config-parameter 'strict_proxy) "true"])
     (check-equal? (get-media-html "https://static.wikia.nocookie.net/a" "image/jpeg")

src/page-search.rkt

@@ -14,6 +14,7 @@
          "config.rkt"
          "data.rkt"
          "../lib/syntax.rkt"
+         "../lib/thread-utils.rkt"
          "../lib/url-utils.rkt"
          "whole-utils.rkt"
          "../lib/xexpr-utils.rkt")
@@ -72,10 +73,13 @@
                               ("formatversion" . "2")
                               ("format" . "json")))))
 
-   (thread-let
+   (define-values (dest-res siteinfo)
-    ([dest-res (log-outgoing dest-url)
+     (thread-values
-               (easy:get dest-url #:timeouts timeouts)]
+      (λ ()
-     [siteinfo (siteinfo-fetch wikiname)])
+        (log-outgoing dest-url)
+        (easy:get dest-url #:timeouts timeouts))
+      (λ ()
+        (siteinfo-fetch wikiname))))
 
    (define data (easy:response-json dest-res))
 
@@ -88,7 +92,7 @@
     #:code 200
     #:headers (build-headers always-headers)
     (λ (out)
-       (write-html body out))))))
+      (write-html body out)))))
 (module+ test
   (parameterize ([(config-parameter 'feature_offline::only) "false"])
     (check-not-false ((query-selector (attribute-selector 'href "/test/wiki/Gacha_Capsule")

src/page-wiki.rkt

@@ -19,6 +19,7 @@
          "data.rkt"
          "../lib/pure-utils.rkt"
          "../lib/syntax.rkt"
+         "../lib/thread-utils.rkt"
          "../lib/tree-updater.rkt"
          "../lib/url-utils.rkt"
          "whole-utils.rkt"
@@ -41,8 +42,10 @@
   (define path (string-join (map path/param-path (cddr (url-path (request-uri req)))) "/"))
   (define source-url (format "https://~a.fandom.com/wiki/~a" wikiname path))
 
-  (thread-let
+  (define-values (dest-res siteinfo)
-   ([dest-res (define dest-url
+    (thread-values
+     (λ ()
+       (define dest-url
          (format "~a/api.php?~a"
                  origin
                  (params->query `(("action" . "parse")
@@ -53,8 +56,9 @@
        (log-outgoing dest-url)
        (easy:get dest-url
                  #:timeouts timeouts
-                        #:headers `#hasheq((cookie . ,(format "theme=~a" (user-cookies^-theme user-cookies)))))]
+                 #:headers `#hasheq((cookie . ,(format "theme=~a" (user-cookies^-theme user-cookies))))))
-    [siteinfo (siteinfo-fetch wikiname)])
+     (λ ()
+       (siteinfo-fetch wikiname))))
 
   (cond
     [(eq? 200 (easy:response-status-code dest-res))
@@ -96,4 +100,4 @@
              #:code 200
              #:headers headers
              (λ (out)
-                (write-html body out))))))])))
+               (write-html body out))))))]))