From 33ee6a0624f86053f670decf2b01fbe762e556e8 Mon Sep 17 00:00:00 2001 From: Cadence Ember Date: Sun, 11 Sep 2022 23:21:37 +1200 Subject: [PATCH] Also display the content on category pages --- src/application-globals.rkt | 5 +- src/page-category.rkt | 93 +++++++++++++++++++++++-------------- src/page-wiki.rkt | 10 ++-- src/syntax.rkt | 62 +++++++++++++++++++++++-- 4 files changed, 125 insertions(+), 45 deletions(-) diff --git a/src/application-globals.rkt b/src/application-globals.rkt index b47ed30..d5d592d 100644 --- a/src/application-globals.rkt +++ b/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))) diff --git a/src/page-category.rkt b/src/page-category.rkt index bfc689f..bb388da 100644 --- a/src/page-category.rkt +++ b/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 members (jp "/query/categorymembers" data)) +(define (generate-results-page dest-url wikiname prefixed-category members-data page) + (define members (jp "/query/categorymembers" members-data)) (generate-wiki-page dest-url wikiname prefixed-category - `(div (@ (class "mw-parser-output")) - (ul (@ (class "my-category-list")) - ,@(map - (λ (result) - (define title (jp "/title" result)) - (define page-path (regexp-replace* #rx" " title "_")) - `(li - (a (@ (href ,(format "/~a/wiki/~a" wikiname page-path))) - ,title))) - members))))) + `(div + ,(update-tree-wiki page wikiname) + (hr) + (h2 ,(format "All Pages in ~a" prefixed-category)) + (div (@ (class "mw-parser-output")) + (ul (@ (class "my-category-list")) + ,@(map + (λ (result) + (define title (jp "/title" result)) + (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" - 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 source-url (format "~a/wiki/~a" origin prefixed-category)) - (define data (easy:response-json dest-res)) - (define body (generate-results-page dest-url wikiname prefixed-category data)) - (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))))) + (thread-let + ([members-data (define dest-url (format "~a/api.php?~a" + 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)) + (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")))))) diff --git a/src/page-wiki.rkt b/src/page-wiki.rkt index 65771a8..bcf13aa 100644 --- a/src/page-wiki.rkt +++ b/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" - "application-globals.rkt") + "url-utils.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) diff --git a/src/syntax.rkt b/src/syntax.rkt index c331493..8205326 100644 --- a/src/syntax.rkt +++ b/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 - if/out) + ; 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) (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)))