Initial commit

* Viewing for wiki pages
* Searches
* Categories
* Logo
* Image proxy
* Config loaded from config.txt
* AGPL 3 license

src/application-globals.rkt

@@ -0,0 +1,73 @@
+#lang racket/base
+(require net/http-easy
+         "config.rkt")
+
+(provide
+ ; timeout durations for http-easy requests
+ timeouts
+ ; generates a consistent template for wiki page content to sit in
+ generate-wiki-page)
+
+(module+ test
+  (require rackunit
+           html-writing))
+
+(define timeouts (make-timeout-config #:lease 5 #:connect 5))
+
+(define (generate-wiki-page source-url wikiname title content)
+  (define (required-styles origin)
+    (map (λ (dest-path) (format dest-path origin))
+         '(#;"~a/load.php?lang=en&modules=skin.fandomdesktop.styles&only=styles&skin=fandomdesktop"
+           #;"~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")))
+  `(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)))
+     (link (@ (rel "stylesheet") (type "text/css") (href "/static/main.css"))))
+    (body (@ (class "skin-fandomdesktop theme-fandomdesktop-light"))
+          (div (@ (class "main-container"))
+               (div (@ (class "fandom-community-header__background tileHorizontally header")))
+               (div (@ (class "page"))
+                    (main (@ (class "page__main"))
+                          (div (@ (class "custom-top"))
+                               (h1 (@ (class "page-title")) ,title)
+                               (nav (@ (class "sitesearch"))
+                                    (form (@ (action ,(format "/~a/search" wikiname)))
+                                          (label "Search "
+                                                 (input (@ (type "text") (name "q")))))))
+                          (div (@ (id "content") #;(class "page-content"))
+                               (div (@ (id "mw-content-text"))
+                                    ,content))
+                          (footer (@ (class "custom-footer"))
+                                  (img (@ (class "my-logo") (src "/static/breezewiki.svg")))
+                                  (div (@ (class "custom-footer__cols"))
+                                       (div
+                                        (p
+                                         (a (@ (href "https://gitdab.com/cadence/breezewiki"))
+                                            ,(format "~a source code" (config-get 'application-name))))
+                                        (p
+                                         (a (@ (href "https://lists.sr.ht/~cadence/breezewiki-discuss"))
+                                            "Discussions / Bug reports / Feature requests"))
+                                        ,(if (config-get 'instance-is-official)
+                                             `(p ,(format "This instance is run by the ~a developer, " (config-get 'application-name))
+                                                 (a (@ (href "https://cadence.moe/contact"))
+                                                    "Cadence."))
+                                             `(p
+                                               ,(format "This unofficial instance is based off the ~a source code, but is not administered by its developer." (config-get 'application-name)))))
+                                       (div
+                                        (p "This page displays proxied content from "
+                                           (a (@ (href ,source-url) (rel "noreferrer")) ,source-url)
+                                           ". Text content is available under the Creative Commons Attribution-Share Alike License 3.0 (Unported), "
+                                           (a (@ (href "https://www.fandom.com/licensing")) "see license info.")
+                                           " Media files may have different copying restrictions.")
+                                        (p ,(format "Fandom is a trademark of Fandom, Inc. ~a is not affiliated with Fandom." (config-get 'application-name))))))))))))
+(module+ test
+  (check-not-false (xexp->html (generate-wiki-page "" "test" "test" '(template)))))

src/config.rkt

@@ -0,0 +1,33 @@
+#lang racket/base
+
+(provide
+ config-get)
+
+(define (config-get key)
+  (hash-ref config key))
+
+(define default-config
+  '((port . 10416)
+    (debug . #f)
+    (instance-is-official . #f) ; please don't turn this on, or you will make me very upset
+    (application-name . "BreezeWiki")))
+
+(define config
+  (make-hasheq
+   (append
+    default-config
+    (with-handlers ([exn:fail:filesystem:errno? (λ (exn)
+                                                  '())])
+      (call-with-input-file "../config.txt"
+        (λ (in)
+          (let loop ([alist '()])
+            (let ([key (read in)]
+                  [value (read in)])
+              (if (eq? value eof)
+                  alist
+                  (loop (cons (cons key
+                                    (cond
+                                      [(eq? value 'true) #t]
+                                      [(eq? value 'false) #f]
+                                      [#t value]))
+                              alist)))))))))))

src/page-category.rkt

@@ -0,0 +1,72 @@
+#lang racket/base
+(require racket/dict
+         racket/list
+         racket/string
+         (prefix-in easy: net/http-easy)
+         ; html libs
+         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"
+         "url-utils.rkt"
+         "xexpr-utils.rkt")
+
+(provide
+ page-category)
+
+(module+ test
+  (require rackunit)
+  (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))
+  (generate-wiki-page
+   dest-url
+   wikiname
+   prefixed-category
+   `(div (@ (class "mw-parser-output"))
+         (ul (@ (class "my-category-list"))
+             ,@(map
+                (λ (result)
+                  (let* ([title (jp "/title" result)]
+                         [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 data (easy:response-json dest-res))
+   (define body (generate-results-page dest-url wikiname prefixed-category data))
+   (when (config-get '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)))))

src/page-not-found.rkt

@@ -0,0 +1,18 @@
+#lang racket/base
+
+(require html-writing
+         web-server/http)
+
+(provide
+ page-not-found)
+
+(define (page-not-found req)
+  (response/output
+   #:code 404
+   (λ (out)
+     (write-html
+      `(html
+        (body
+         (h1 "Not found.")
+         (pre ,(format "~v" req))))
+      out))))

src/page-proxy.rkt

@@ -0,0 +1,30 @@
+#lang racket/base
+(require racket/dict
+         racket/match
+         racket/port
+         ; libs
+         (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)
+         "url-utils.rkt")
+
+(provide
+ page-proxy)
+
+(define (page-proxy req)
+  (match (dict-ref (url-query (request-uri req)) 'dest #f)
+    [(? string? dest)
+     (if (is-fandom-url? dest)
+         (let ([dest-r (easy:get dest #:stream? #t)])
+           (response/output
+            #:code (easy:response-status-code dest-r)
+            #:mime-type (easy:response-headers-ref dest-r 'content-type)
+            (λ (out)
+              (copy-port (easy:response-output dest-r) out))))
+         (next-dispatcher))]
+    [#f (next-dispatcher)]))

src/page-search.rkt

@@ -0,0 +1,82 @@
+#lang racket/base
+(require racket/dict
+         racket/list
+         racket/string
+         (prefix-in easy: net/http-easy)
+         ; html libs
+         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"
+         "url-utils.rkt"
+         "xexpr-utils.rkt")
+
+(provide
+ page-search)
+
+(module+ test
+  (require rackunit)
+  (define search-json-data
+    '#hasheq((batchcomplete . #t) (query . #hasheq((search . (#hasheq((ns . 0) (pageid . 219) (size . 1482) (snippet . "") (timestamp . "2022-08-21T08:54:23Z") (title . "Gacha Capsule") (wordcount . 214)) #hasheq((ns . 0) (pageid . 201) (size . 1198) (snippet . "") (timestamp . "2022-07-11T17:52:47Z") (title . "Badges") (wordcount . 181)))))))))
+
+(define (generate-results-page dest-url wikiname query data)
+  (define search-results (jp "/query/search" data))
+  (generate-wiki-page
+   dest-url
+   wikiname
+   "Search Results"
+   `(div (@ (class "mw-parser-output"))
+         (p ,(format "~a results found for " (length search-results))
+            (strong ,query))
+         (ul ,@(map
+                (λ (result)
+                  (let* ([title (jp "/title" result)]
+                         [page-path (regexp-replace* #rx" " title "_")]
+                         [timestamp (jp "/timestamp" result)]
+                         [wordcount (jp "/wordcount" result)]
+                         [size (jp "/size" result)])
+                    `(li (@ (class "my-result"))
+                         (a (@ (class "my-result__link") (href ,(format "/~a/wiki/~a" wikiname page-path)))
+                            ,title)
+                         (div (@ (class "my-result__info"))
+                              "last edited "
+                              (time (@ (datetime ,timestamp)) ,(list-ref (string-split timestamp "T") 0))
+                              ,(format ", ~a words, ~a kb"
+                                       wordcount
+                                       (exact->inexact (/ (round (/ size 100)) 10)))))))
+                search-results)))))
+
+(define (page-search req)
+  (response-handler
+   (define wikiname (path/param-path (first (url-path (request-uri req)))))
+   (define query (dict-ref (url-query (request-uri req)) 'q #f))
+
+   (define origin (format "https://~a.fandom.com" wikiname))
+   (define dest-url (format "~a/api.php?~a"
+                            origin
+                            (params->query `(("action" . "query")
+                                             ("list" . "search")
+                                             ("srsearch" . ,query)
+                                             ("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))
+
+   (define body (generate-results-page dest-url wikiname query data))
+   (when (config-get '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/Gacha_Capsule")
+                                    (generate-results-page "" "test" "Gacha" search-json-data)))))

src/page-wiki.rkt

@@ -0,0 +1,234 @@
+#lang racket/base
+(require racket/dict
+         racket/function
+         racket/list
+         racket/string
+         ; libs
+         (prefix-in easy: net/http-easy)
+         ; html libs
+         html-parsing
+         html-writing
+         ; web server libs
+         net/url
+         web-server/http
+         web-server/dispatchers/dispatch
+         ; my libs
+         "pure-utils.rkt"
+         "xexpr-utils.rkt"
+         "url-utils.rkt"
+         "application-globals.rkt")
+
+(provide
+ page-wiki)
+
+(module+ test
+  (require rackunit)
+  (define wiki-document
+    '(*TOP*
+      (div (@ (class "mw-parser-output"))
+           (aside (@ (role "region") (class "portable-infobox pi-theme-wikia pi-layout-default"))
+                  (h2 (@ (class "pi-item pi-title") (data-source "title"))
+                      "Infobox Title")
+                  (figure (@ (class "pi-item pi-image") (data-sourec "image"))
+                          (a (@ (href "https://static.wiki.nocookie.net/nice-image.png") (class "image image-thumbnail") (title ""))
+                             (img (@ (src "https://static.wiki.nocookie.net/nice-image-thumbnail.png") (class "pi-image-thumbnail")))))
+                  (div (@ (class "pi-item pi-data") (data-source "description"))
+                       (h3 (@ (class "pi-data-label"))
+                           "Description")
+                       (div (@ (class "pi-data-value"))
+                            "Mystery infobox!")))
+           (div (@ (data-test-collapsesection) (class "collapsible collapsetoggle-inline collapsed"))
+                (i (b "This section is hidden for dramatic effect."))
+                (div (@ (class "collapsible-content"))
+                     (p "Another page link: "
+                        (a (@ (data-test-wikilink) (href "https://test.fandom.com/wiki/Another_Page") (title "Another Page"))
+                           "Another Page"))))))))
+
+(define (preprocess-html-wiki html)
+  (define (rr* find replace contents)
+    (regexp-replace* find contents replace))
+  ((compose1
+    ; fix navbox list nesting
+    ; navbox on right of page has incorrect html "<td ...><li>" and the xexpr parser puts the <li> much further up the tree
+    ; add a <ul> to make the parser happy
+    ; usage: /fallout/wiki/Fallout:_New_Vegas_achievements_and_trophies
+    (curry rr* #rx"(<td[^>]*>\n?)(<li>)" "\\1<ul>\\2")
+    ; change <figcaption><p> to <figcaption><span> to make the parser happy
+    (curry rr* #rx"(<figcaption[^>]*>)[ \t]*<p class=\"caption\">([^<]*)</p>" "\\1<span class=\"caption\">\\2</span>"))
+   html))
+(module+ test
+  (check-equal? (preprocess-html-wiki "<td class=\"va-navbox-column\" style=\"width: 33%\">\n<li>Hey</li>")
+                "<td class=\"va-navbox-column\" style=\"width: 33%\">\n<ul><li>Hey</li>")
+  (check-equal? (preprocess-html-wiki "<figure class=\"thumb tright\" style=\"width: 150px\"><a class=\"image\"><img></a><noscript><a><img></a></noscript><figcaption class=\"thumbcaption\"> 	<p class=\"caption\">Caption text.</p></figcaption></figure>")
+                "<figure class=\"thumb tright\" style=\"width: 150px\"><a class=\"image\"><img></a><noscript><a><img></a></noscript><figcaption class=\"thumbcaption\"><span class=\"caption\">Caption text.</span></figcaption></figure>"))
+
+(define (update-tree-wiki tree wikiname)
+  (update-tree
+   (λ (element element-type attributes children)
+     ;; replace whole element?
+     (cond
+       ; wrap tables in a div.table-scroller
+       [(and (eq? element-type 'table)
+             (has-class? "wikitable" attributes)
+             (not (dict-has-key? attributes 'data-scrolling)))
+        `(div
+          ((class "table-scroller"))
+          ((,element-type (@ (data-scrolling) ,@attributes)
+                          ,@children)))]
+       ; exclude empty figcaptions
+       [(and (eq? element-type 'figcaption)
+             (or (eq? (length (filter element-is-element? children)) 0)
+                 ((query-selector (λ (element-type attributes children)
+                                    (eq? element-type 'use))
+                                  element))))
+        return-no-element]
+       ; exclude infobox items that are videos, and gallery items that are videos
+       [(and (or (has-class? "pi-item" attributes)
+                 (has-class? "wikia-gallery-item" attributes))
+             ((query-selector (λ (element-type attributes children)
+                                (has-class? "video-thumbnail" attributes))
+                              element)))
+        return-no-element]
+       ; exclude the invisible brackets after headings
+       [(and (eq? element-type 'span)
+             (has-class? "mw-editsection" attributes))
+        return-no-element]
+       ; display a link instead of an iframe
+       [(eq? element-type 'iframe)
+        (let ([src (car (dict-ref attributes 'src null))])
+          `(a
+            ((class "iframe-alternative") (href ,src))
+            (,(format "Embedded media: ~a" src))))]
+       [#t
+        (list element-type
+              ;; attributes
+              ((compose1
+                ; uncollapsing
+                (curry attribute-maybe-update 'class
+                       (λ (class)
+                         (string-join
+                          ((compose1
+                            ; uncollapse all navbox items (bottom of page mass navigation)
+                            (curry u
+                                   (λ (classlist) (and (eq? element-type 'table)
+                                                       (member "navbox" classlist)
+                                                       (member "collapsed" classlist)))
+                                   (λ (classlist) (filter (curry (negate equal?) "collapsed") classlist)))
+                            ; uncollapse portable-infobox sections
+                            (curry u
+                                   (λ (classlist) (and (eq? element-type 'section)
+                                                       (member "pi-collapse" classlist)))
+                                   (λ (classlist) (filter (λ (v)
+                                                            (and (not (equal? v "pi-collapse-closed"))
+                                                                 (not (equal? v "pi-collapse"))))
+                                                          classlist)))
+                            ; generic: includes article sections and tables, probably more
+                            (curry u
+                                   (λ (classlist) (and (member "collapsible" classlist)
+                                                       (member "collapsed" classlist)))
+                                   (λ (classlist) (filter (curry (negate equal?) "collapsed") classlist))))
+                           (string-split class " "))
+                          " ")))
+                ; change links to stay on the same wiki
+                (curry attribute-maybe-update 'href
+                       (λ (href)
+                         ((compose1
+                           (λ (href) (regexp-replace #rx"^(/wiki/.*)" href (format "/~a\\1" wikiname)))
+                           (λ (href) (regexp-replace #rx"^https://([a-z-]+).fandom.com(/wiki/.*)" href "/\\1\\2")))
+                          href)))
+                ; add noreferrer to a.image
+                (curry u
+                       (λ (v) (and (eq? element-type 'a)
+                                   (has-class? "image" v)))
+                       (λ (v) (dict-update attributes 'rel (λ (s)
+                                                             (list (string-append (car s) " noreferrer")))
+                                           '(""))))
+                ; proxy images from inline styles
+                (curry attribute-maybe-update 'style
+                       (λ (style)
+                         (regexp-replace #rx"url\\(['\"]?(.*?)['\"]?\\)" style
+                                         (λ (whole url)
+                                           (string-append
+                                            "url("
+                                            (u-proxy-url url)
+                                            ")")))))
+                ; proxy images from src attributes
+                (curry attribute-maybe-update 'src u-proxy-url)
+                ; don't lazyload images
+                (curry u
+                       (λ (v) (dict-has-key? v 'data-src))
+                       (λ (v) (attribute-maybe-update 'src (λ (_) (car (dict-ref v 'data-src))) v)))
+                ; don't use srcset - TODO: use srcset?
+                (λ (v) (dict-remove v 'srcset)))
+               attributes)
+              ;; children
+              ((compose1
+                ; wrap blinking animated images in a slot so they can be animated with CSS
+                (curry u
+                       (λ (v) (and (has-class? "animated" attributes)
+                                   ((length v) . > . 1)))
+                       (λ (v)
+                         `((span (@ (class "animated-slot") (style ,(format "--steps: ~a" (length v))))
+                                 ,@v)))))
+               children))]))
+   tree))
+(module+ test
+  (define transformed (update-tree-wiki wiki-document "test"))
+  ; check that wikilinks are changed to be local
+  (check-equal? (get-attribute 'href (bits->attributes
+                                      ((query-selector
+                                        (λ (t a c) (dict-has-key? a 'data-test-wikilink))
+                                        transformed))))
+                "/test/wiki/Another_Page")
+  ; check that a.image has noreferrer
+  (check-equal? (get-attribute 'rel (bits->attributes
+                                     ((query-selector
+                                       (λ (t a c) (and (eq? t 'a)
+                                                       (has-class? "image" a)))
+                                       transformed))))
+                " noreferrer")
+  ; check that article collapse sections become uncollapsed
+  (check-equal? (get-attribute 'class (bits->attributes
+                                       ((query-selector
+                                         (λ (t a c) (dict-has-key? a 'data-test-collapsesection))
+                                         transformed))))
+                "collapsible collapsetoggle-inline"))
+
+(define (page-wiki req)
+  (define wikiname (path/param-path (first (url-path (request-uri req)))))
+  (define origin (format "https://~a.fandom.com" wikiname))
+  (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))
+
+  (define dest-url (format "~a/api.php?~a"
+                           origin
+                           (params->query `(("action" . "parse")
+                                            ("page" . ,path)
+                                            ("prop" . "text")
+                                            ("formatversion" . "2")
+                                            ("format" . "json")))))
+  (printf "out: ~a~n" dest-url)
+  (define dest-res (easy:get dest-url #:timeouts timeouts))
+
+  (cond
+    [(eq? 200 (easy:response-status-code dest-res))
+     (let* ([data (easy:response-json dest-res)]
+            [title (jp "/parse/title" data "")]
+            [page-html (jp "/parse/text" data "")]
+            [page-html (preprocess-html-wiki page-html)]
+            [page (html->xexp page-html)])
+       (if (equal? "missingtitle" (jp "/error/code" data #f))
+           (next-dispatcher)
+           (response-handler
+            (define body
+              (generate-wiki-page source-url wikiname title (update-tree-wiki page wikiname)))
+            (define redirect-msg ((query-selector (attribute-selector 'class "redirectMsg") body)))
+            (response/output
+             #:code 200
+             #:headers (if redirect-msg
+                           (let* ([dest (get-attribute 'href (bits->attributes ((query-selector (λ (t a c) (eq? t 'a)) redirect-msg))))]
+                                  [value (bytes-append #"0;url=" (string->bytes/utf-8 dest))])
+                             (list (header #"Refresh" value)))
+                           (list))
+             (λ (out)
+               (write-html body out))))))]))

src/pure-utils.rkt

@@ -0,0 +1,30 @@
+#lang typed/racket/base
+
+(provide
+ ; call the updater on the dictionary key only if it has that key
+ alist-maybe-update
+ ; update a value only if a condition succeeds on it
+ u)
+
+(module+ test
+  (require "typed-rackunit.rkt"))
+
+(: alist-maybe-update (∀ (A B) ((Listof (Pairof A B)) A (B -> B) -> (Listof (Pairof A B)))))
+(define (alist-maybe-update alist key updater)
+  (map (λ ([p : (Pairof A B)])
+         (if (eq? (car p) key)
+             (cons (car p) (updater (cdr p)))
+             p))
+       alist))
+(module+ test
+  (check-equal? (alist-maybe-update '((a . 5) (b . 6)) 'a (λ ([x : Number]) (+ x 10)))
+                '((a . 15) (b . 6)))
+  (check-equal? (alist-maybe-update '((b . 6)) 'a (λ ([x : Number]) (+ x 10)))
+                '((b . 6))))
+
+(: u (∀ (A) ((A -> Any) (A -> A) A -> A)))
+(define (u condition updater value)
+  (if (condition value) (updater value) value))
+(module+ test
+  (check-equal? (u (λ ([x : Integer]) (< x 5)) (λ ([x : Integer]) (* x -1)) 4) -4)
+  (check-equal? (u (λ ([x : Integer]) (< x 5)) (λ ([x : Integer]) (* x -1)) 8) 8))

src/server.rkt

@@ -0,0 +1,39 @@
+#lang racket/base
+(require racket/path
+         net/url
+         web-server/servlet-dispatch
+         web-server/dispatchers/filesystem-map
+         (prefix-in pathprocedure: web-server/dispatchers/dispatch-pathprocedure)
+         (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
+         (prefix-in lift: web-server/dispatchers/dispatch-lift)
+         (prefix-in filter: web-server/dispatchers/dispatch-filter)
+         (prefix-in files: web-server/dispatchers/dispatch-files)
+         "config.rkt"
+         "page-category.rkt"
+         "page-not-found.rkt"
+         "page-proxy.rkt"
+         "page-wiki.rkt"
+         "page-search.rkt")
+
+(define mime-types
+  (hash #".css" #"text/css"
+        #".svg" #"image/svg+xml"))
+
+(serve/launch/wait
+ #:port (config-get 'port)
+ (λ (quit)
+   (sequencer:make
+    (pathprocedure:make "/proxy" page-proxy)
+    (filter:make #rx"^/[a-z-]+/wiki/Category:.+$" (lift:make page-category))
+    (filter:make #rx"^/[a-z-]+/wiki/.+$" (lift:make page-wiki))
+    (filter:make #rx"^/[a-z-]+/search$" (lift:make page-search))
+    (filter:make #rx"^/static/" (files:make
+                                 #:url->path
+                                 (lambda (u)
+                                   ((make-url->path "../static")
+                                    (struct-copy url u [path (cdr (url-path u))])))
+                                 #:path->mime-type
+                                 (lambda (u)
+                                   (hash-ref mime-types (path-get-extension u)))
+                                 #:cache-no-cache (config-get 'debug) #;"browser applies heuristics if unset"))
+    (lift:make page-not-found))))

src/typed-rackunit.rkt

@@ -0,0 +1,11 @@
+#lang typed/racket/base
+
+(provide
+ check-equal?
+ check-true
+ check-false)
+
+(require/typed rackunit
+  [check-equal? (Any Any -> Void)]
+  [check-true (Any -> Void)]
+  [check-false (Any -> Void)])

src/url-utils.rkt

@@ -0,0 +1,71 @@
+#lang typed/racket/base
+(require racket/string
+         "pure-utils.rkt")
+
+(provide
+ ; make a query string from an association list of strings
+ params->query
+ ; make a proxied version of a fandom url
+ u-proxy-url
+ ; check whether a url is on a domain controlled by fandom
+ is-fandom-url?)
+
+(module+ test
+  (require "typed-rackunit.rkt"))
+
+;; https://url.spec.whatwg.org/#urlencoded-serializing
+
+(define urlencoded-set '(#\! #\' #\( #\) #\~ ; urlencoded set
+                         #\$ #\% #\& #\+ #\, ; component set
+                         #\/ #\: #\; #\= #\@ #\[ #\\ #\] #\^ #\| ; userinfo set
+                         #\? #\` #\{ #\} ; path set
+                         #\  #\" #\# #\< #\> ; query set
+                         ; c0 controls included elsewhere
+                         ; higher ranges included elsewhere
+                         ))
+
+(: percent-encode (String (Listof Char) Boolean -> Bytes))
+(define (percent-encode value set space-as-plus)
+  (define b (string->bytes/utf-8 value))
+  (apply bytes-append
+         (for/list ([char b]) : (Listof Bytes)
+                   (cond
+                     [(and space-as-plus (eq? char 32))
+                      #"+"]
+                     [(or (member (integer->char char) set)
+                          (char . > . #x7E)
+                          (char . <= . #x1F))
+                      (bytes-append #"%" (string->bytes/latin-1
+                                          (string-upcase (number->string char 16))))]
+                     [#t
+                      (bytes char)]))))
+
+(: params->query ((Listof (Pair String String)) -> String))
+(define (params->query params)
+  (string-join
+   (map (λ ([p : (Pair String String)])
+          (format "~a=~a"
+                  (percent-encode (car p) urlencoded-set #t)
+                  (percent-encode (cdr p) urlencoded-set #t)))
+        params)
+   "&"))
+(module+ test
+  (check-equal? (params->query '(("hello" . "world")))
+                "hello=world")
+  (check-equal? (params->query '(("a" . "hello world''") ("utf8" . "✓")))
+                "a=hello+world%27%27&utf8=%E2%9C%93"))
+
+(: is-fandom-url? (String -> Boolean))
+(define (is-fandom-url? url)
+  (regexp-match? #rx"^https://static.wikia.nocookie.net/|^https://[a-z-]*.fandom.com/" url))
+(module+ test
+  (check-true (is-fandom-url? "https://static.wikia.nocookie.net/wikiname/images/2/2f/SomeImage.jpg/revision/latest?cb=20110210094136"))
+  (check-true (is-fandom-url? "https://test.fandom.com/wiki/Some_Page"))
+  (check-false (is-fandom-url? "https://cadence.moe")))
+
+(: u-proxy-url (String -> String))
+(define (u-proxy-url url)
+  (u
+   is-fandom-url?
+   (λ ([v : String]) (string-append "/proxy?" (params->query `(("dest" . ,url)))))
+   url))

src/xexpr-utils.rkt

@@ -0,0 +1,200 @@
+#lang racket/base
+(require racket/dict
+         racket/function
+         racket/generator
+         racket/match
+         racket/string
+         (only-in json-pointer json-pointer-value)
+         (only-in web-server/http response/output)
+         "pure-utils.rkt")
+
+(provide
+ ;; with whole xexprs
+ ; xexpr for an "empty" element, which in reality uses <template>
+ return-no-element
+ ; query a tree for elements matching a condition
+ query-selector
+ ; update a tree with a function called on each element
+ update-tree
+
+ ;; with bits of xexprs
+ ; predicates
+ element-is-bits?
+ element-is-xattributes?
+ element-is-element?
+ element-is-content?
+
+ ;; with attributes
+ ; find the attributes in some bits of an element
+ bits->attributes
+ ; get attribute value from some attributes
+ get-attribute
+ ; update an attribute if it is present (otherwise no change)
+ attribute-maybe-update
+ ; make an attribute selector for use in query-selector
+ attribute-selector
+ ; do these attributes have a certain value in their class?
+ has-class?
+
+ ;; with json
+ ; get value in json structure using a *j*son *p*ointer, optionally with default value for not present
+ jp
+
+ ; error catching for http responses
+ response-handler)
+
+(module+ test
+  (require rackunit)
+  (define demo-attributes
+    '(span (@ (title "Inside joke."))
+           "To get to the other side."
+           (@ (style "color: blue"))))
+  (define demo-document
+    '(html
+      (@ (lang "en"))
+      (head
+       (title "Hello world!"))
+      (body
+       (h1 "Hello world!")
+       (p "Welcome to my "
+          (span (@ (style "color: yellow")
+                   (title "Really."))
+                (em "cool"))
+          "website.")))))
+
+; replacing with a template element removes it from the rendered document
+(define return-no-element '(template
+                            ()
+                            ()))
+
+; "bits" is attributes or real elements (non-string)
+(define (element-is-bits? element)
+  (pair? element))
+(module+ test
+  (check-true (element-is-bits? '(span "hi")))
+  (check-true (element-is-bits? '(@ (alt "Cute cat."))))
+  (check-false (element-is-bits? "hi")))
+
+; "xattributes" is attributes hugged by @
+(define (element-is-xattributes? element)
+  (and (element-is-bits? element) (eq? '@ (car element))))
+(module+ test
+  (check-false (element-is-xattributes? '(span "hi")))
+  (check-true (element-is-xattributes? '(@ (alt "Cute cat."))))
+  (check-false (element-is-xattributes? '((alt "Cute cat."))))
+  (check-false (element-is-xattributes? "hi")))
+
+; "element" is a real element with a type and everything (non-string, non-attributes)
+(define (element-is-element? element)
+  (and (element-is-bits? element) (not (element-is-xattributes? element))))
+(module+ test
+  (check-true (element-is-element? '(span "hi")))
+  (check-false (element-is-element? '(@ (alt "Cute cat."))))
+  (check-false (element-is-element? "hi")))
+
+; "element content" is a real element or a string
+(define (element-is-content? element)
+  (or (string? element) (element-is-element? element)))
+(module+ test
+  (check-true (element-is-content? '(span "hi")))
+  (check-false (element-is-content? '(@ (alt "Cute cat."))))
+  (check-true (element-is-content? "hi")))
+
+(define (xattributes->attributes xattrs)
+  (filter pair? xattrs))
+
+(define (bits->attributes bits)
+  (xattributes->attributes (apply append (filter element-is-xattributes? bits))))
+(module+ test
+  (check-equal? (bits->attributes demo-attributes)
+                '((title "Inside joke.") (style "color: blue"))))
+
+(define (get-attribute name attributes)
+  (let ([a (assq name attributes)])
+    (if (pair? a)
+        (cadr a)
+        #f)))
+(module+ test
+  (check-equal? (get-attribute 'title (bits->attributes demo-attributes)) "Inside joke."))
+
+(define (attribute-maybe-update key updater attributes)
+  (alist-maybe-update attributes key (λ (v) (map updater v))))
+(module+ test
+  (check-equal? (attribute-maybe-update 'a (λ (x) (+ x 10)) '((a 5) (b 6)))
+                '((a 15) (b 6))))
+
+(define (attribute-selector name value)
+  (λ (element-type attributes children)
+    (equal? (get-attribute name attributes) value)))
+
+(define (query-selector selector element)
+  (generator
+   ()
+   (let loop ([element element])
+     (let* ([element-type (car element)]
+            ; (append) is a clean and general approach to finding and combining any attributes
+            ; (filter pair?) is to get the actual attributes and leaves out the @ signs
+            [attributes (bits->attributes (cdr element))]
+            ; only recurse through real children
+            [children (filter element-is-element? (cdr element))])
+       (cond
+         [(equal? element-type '*DECL*) #f]
+         [(equal? element-type '@) #f]
+         [#t
+          (when (selector element-type attributes children)
+            (yield element))
+          (for ([child children]) (loop child))])))
+   #f))
+(module+ test
+  (let ([result (query-selector (attribute-selector 'title "Really.")
+                                demo-document)])
+    (check-equal? (result) '(span (@ (style "color: yellow")
+                                     (title "Really."))
+                                  (em "cool")))
+    (check-equal? (result) #f)))
+
+(define (update-tree transformer element)
+  (let loop ([element element])
+    (let* ([element-type (car element)]
+           ; (append) is a clean and general approach to finding and combining any attributes
+           ; (filter pair?) is to get the actual attributes and leaves out the @ signs
+           [attributes (bits->attributes (cdr element))]
+           ; provide elements and strings
+           [contents (filter element-is-content? (cdr element))])
+      (if (or (equal? element-type '*DECL)
+              (equal? element-type '@))
+          ; special element, do nothing
+          element
+          ; regular element, transform it
+          (match (transformer element element-type attributes contents)
+            [(list element-type attributes contents)
+             (append (list element-type)
+                     (if (pair? attributes) (list (append '(@) attributes)) (list))
+                     (map (λ (content)
+                            (if (element-is-element? content) (loop content) content))
+                          contents))])))))
+
+(define (has-class? name attributes)
+  (and (member name (string-split (or (get-attribute 'class attributes) "") " ")) #t))
+(module+ test
+  (check-true (has-class? "red" '((class "yellow red blue"))))
+  (check-false (has-class? "red" '((class "yellow blue"))))
+  (check-false (has-class? "red" '((title "Inside joke.")))))
+
+(define (jp pointer document [else null])
+  (with-handlers ([exn:fail:contract? (λ (exn) (cond
+                                                 [(null? else) (raise exn)]
+                                                 [(procedure? else) (else)]
+                                                 [#t else]))])
+    (json-pointer-value pointer document)))
+
+(define-syntax-rule (response-handler body ...)
+  (with-handlers ([exn:fail? (λ (e)
+                               (response/output
+                                #:code 500
+                                #:mime-type #"text/plain"
+                                (λ (out)
+                                  (for ([port (list (current-output-port) out)])
+                                    (displayln "Exception raised in Racket code at response generation time:" port)
+                                    (displayln (exn-message e) port)))))])
+    body ...))