Also display the content on category pages

src/application-globals.rkt

@@ -66,13 +66,12 @@
            #;"~a/load.php?lang=en&modules=ext.gadget.dungeonsWiki%2CearthWiki%2Csite-styles%2Csound-styles&only=styles&skin=fandomdesktop"
            #;"~a/load.php?lang=en&modules=site.styles&only=styles&skin=fandomdesktop"
            ; combine the above entries into a single request for potentially extra speed - fandom.com doesn't even do this!
-           "~a/load.php?lang=en&modules=skin.fandomdesktop.styles%7Cext.fandom.PortableInfoboxFandomDesktop.css%7Cext.fandom.GlobalComponents.CommunityHeaderBackground.css%7Cext.gadget.site-styles%2Csound-styles%7Csite.styles&only=styles&skin=fandomdesktop"
+           "~a/wikia.php?controller=ThemeApi&method=themeVariables"
-           "~a/wikia.php?controller=ThemeApi&method=themeVariables")))
+           "~a/load.php?lang=en&modules=skin.fandomdesktop.styles%7Cext.fandom.PortableInfoboxFandomDesktop.css%7Cext.fandom.GlobalComponents.CommunityHeaderBackground.css%7Cext.gadget.site-styles%2Csound-styles%7Csite.styles&only=styles&skin=fandomdesktop")))
   `(html
     (head
      (meta (@ (name "viewport") (content "width=device-width, initial-scale=1")))
      (title ,(format "~a | ~a" title (config-get 'application_name)))
-     (style ":root { --theme-page-background-color: #dfdfe0 }") ; fallback in case styles don't load fast enough
      ,@(map (λ (url)
               `(link (@ (rel "stylesheet") (type "text/css") (href ,url))))
             (required-styles (format "https://~a.fandom.com" wikiname)))

src/page-category.rkt

@@ -4,14 +4,17 @@
          racket/string
          (prefix-in easy: net/http-easy)
          ; html libs
+         html-parsing
          html-writing
          ; web server libs
          net/url
          web-server/http
          (only-in web-server/dispatchers/dispatch next-dispatcher)
          #;(only-in web-server/http/redirect redirect-to)
-         "config.rkt"
          "application-globals.rkt"
+         "config.rkt"
+         "page-wiki.rkt"
+         "syntax.rkt"
          "url-utils.rkt"
          "xexpr-utils.rkt")
 
@@ -23,50 +26,70 @@
   (define category-json-data
     '#hasheq((batchcomplete . #t) (continue . #hasheq((cmcontinue . "page|4150504c45|41473") (continue . "-||"))) (query . #hasheq((categorymembers . (#hasheq((ns . 0) (pageid . 25049) (title . "Item (entity)")) #hasheq((ns . 0) (pageid . 128911) (title . "3D")) #hasheq((ns . 0) (pageid . 124018) (title . "A Very Fine Item")) #hasheq((ns . 0) (pageid . 142208) (title . "Amethyst Shard")) #hasheq((ns . 0) (pageid . 121612) (title . "Ankle Monitor")))))))))
 
-(define (generate-results-page dest-url wikiname prefixed-category data)
+(define (generate-results-page dest-url wikiname prefixed-category members-data page)
-  (define members (jp "/query/categorymembers" data))
+  (define members (jp "/query/categorymembers" members-data))
   (generate-wiki-page
    dest-url
    wikiname
    prefixed-category
-   `(div (@ (class "mw-parser-output"))
+   `(div
-         (ul (@ (class "my-category-list"))
+     ,(update-tree-wiki page wikiname)
-             ,@(map
+     (hr)
-                (λ (result)
+     (h2 ,(format "All Pages in ~a" prefixed-category))
-                  (define title (jp "/title" result))
+     (div (@ (class "mw-parser-output"))
-                  (define page-path (regexp-replace* #rx" " title "_"))
+          (ul (@ (class "my-category-list"))
-                  `(li
+              ,@(map
-                    (a (@ (href ,(format "/~a/wiki/~a" wikiname page-path)))
+                 (λ (result)
-                       ,title)))
+                   (define title (jp "/title" result))
-                members)))))
+                   (define page-path (regexp-replace* #rx" " title "_"))
+                   `(li
+                     (a (@ (href ,(format "/~a/wiki/~a" wikiname page-path)))
+                        ,title)))
+                 members))))))
 
 (define (page-category req)
   (response-handler
    (define wikiname (path/param-path (first (url-path (request-uri req)))))
    (define prefixed-category (path/param-path (caddr (url-path (request-uri req)))))
-
    (define origin (format "https://~a.fandom.com" wikiname))
-   (define dest-url (format "~a/api.php?~a"
+   (define source-url (format "~a/wiki/~a" origin prefixed-category))
-                            origin
-                            (params->query `(("action" . "query")
-                                             ("list" . "categorymembers")
-                                             ("cmtitle" . ,prefixed-category)
-                                             ("cmlimit" . "max")
-                                             ("formatversion" . "2")
-                                             ("format" . "json")))))
-   (printf "out: ~a~n" dest-url)
-   (define dest-res (easy:get dest-url #:timeouts timeouts))
 
-   (define data (easy:response-json dest-res))
+   (thread-let
-   (define body (generate-results-page dest-url wikiname prefixed-category data))
+    ([members-data (define dest-url (format "~a/api.php?~a"
-   (when (config-true? 'debug)
+                                       origin
-     ; used for its side effects
+                                       (params->query `(("action" . "query")
-     ; convert to string with error checking, error will be raised if xexp is invalid
+                                                        ("list" . "categorymembers")
-     (xexp->html body))
+                                                        ("cmtitle" . ,prefixed-category)
-   (response/output
+                                                        ("cmlimit" . "max")
-    #:code 200
+                                                        ("formatversion" . "2")
-    (λ (out)
+                                                        ("format" . "json")))))
-      (write-html body out)))))
+              (printf "out: ~a~n" dest-url)
+              (define dest-res (easy:get dest-url #:timeouts timeouts))
+              (easy:response-json dest-res)]
+     [page-data (define dest-url (format "~a/api.php?~a"
+                                    origin
+                                    (params->query `(("action" . "parse")
+                                                     ("page" . ,prefixed-category)
+                                                     ("prop" . "text")
+                                                     ("formatversion" . "2")
+                                                     ("format" . "json")))))
+           (printf "out: ~a~n" dest-url)
+           (define dest-res (easy:get dest-url #:timeouts timeouts))
+           (easy:response-json dest-res)])
+
+    (define page-html (preprocess-html-wiki (jp "/parse/text" page-data "")))
+    (define page (html->xexp page-html))
+    (define body (generate-results-page source-url wikiname prefixed-category members-data page))
+
+    (when (config-true? 'debug)
+      ; used for its side effects
+      ; convert to string with error checking, error will be raised if xexp is invalid
+      (xexp->html body))
+    (response/output
+     #:code 200
+     (λ (out)
+       (write-html body out))))))
 (module+ test
   (check-not-false ((query-selector (attribute-selector 'href "/test/wiki/Ankle_Monitor")
-                                    (generate-results-page "" "test" "Category:Items" category-json-data)))))
+                                    (generate-results-page "" "test" "Category:Items" category-json-data
+                                                           '(div "page text"))))))

src/page-wiki.rkt

@@ -13,14 +13,18 @@
          web-server/http
          web-server/dispatchers/dispatch
          ; my libs
+         "application-globals.rkt"
          "config.rkt"
          "pure-utils.rkt"
          "xexpr-utils.rkt"
-         "url-utils.rkt"
+         "url-utils.rkt")
-         "application-globals.rkt")
 
 (provide
- page-wiki)
+ ; used by the web server
+ page-wiki
+ ; used by page-category, and similar pages that are partially wiki pages
+ update-tree-wiki
+ preprocess-html-wiki)
 
 (module+ test
   (require rackunit)

src/syntax.rkt

@@ -2,8 +2,10 @@
 (require (for-syntax racket/base))
 
 (provide
- ; help make a nested if where the false results are the same
+ ; help make a nested if. if/in will gain the same false form of its containing if/out.
- if/out)
+ if/out
+ ; let, but the value for each variable is evaluated within a thread
+ thread-let)
 
 (module+ test
   (require rackunit)
@@ -15,7 +17,10 @@
 ;; it's in a submodule so that it can be required in both levels, for testing
 
 (module transform racket/base
-  (provide transform-if/out)
+  (provide
+   transform-if/out
+   transform-thread-let)
+
   (define (transform-if/out stx)
     (define tree (cdr (syntax->datum stx))) ; condition true false
     (define else (cddr tree)) ; the else branch cons cell
@@ -37,7 +42,27 @@
           [(pair? node) (cons (walk (car node)) (walk (cdr node)))]
           ; something else that can't be recursed into, so pass it through
           [#t node])))
-    (datum->syntax stx (cons 'if result))))
+    (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)))))
 
 ;; the syntax definitions and their tests go below here
 
@@ -52,3 +77,32 @@
   (check-equal? (if/out #f (if/in #t 'yes) 'no) 'no)
   (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)))