forked from cadence/breezewiki
Replace thread-let with thread-utils
This commit is contained in:
parent
5fa6e2fb9e
commit
501dcaa3fc
GPG key ID:
BC1C2C61CF521B17
9 changed files with 255 additions and 215 deletions
|
|
@ -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
|
||||
|
|
|
|||
72
lib/thread-utils.rkt
Normal file
72
lib/thread-utils.rkt
Normal file
|
|
@ -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!"))
|
||||
|
|
@ -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")
|
||||
(with-input-from-file "../misc/Frog.html"
|
||||
(when (file-exists? "../storage/Frog.html")
|
||||
(with-input-from-file "../storage/Frog.html"
|
||||
(λ ()
|
||||
(define tree (html->xexp (current-input-port)))
|
||||
(time (length (update-tree-wiki tree "minecraft")))))))
|
||||
|
|
|
|||
|
|
@ -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))]
|
||||
[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/"))
|
||||
(not (string-contains? ua "edg/"))
|
||||
(not (string-contains? ua "mobile")))))])
|
||||
(cond/var
|
||||
[(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
|
||||
[#t (and (not (string-contains? ua "edge/"))
|
||||
(not (string-contains? ua "edg/"))
|
||||
(not (string-contains? ua "mobile")))])])
|
||||
`(div (@ (class "bw-top-banner"))
|
||||
,balloon
|
||||
(div
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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,55 +70,59 @@
|
|||
(define origin (format "https://~a.fandom.com" wikiname))
|
||||
(define source-url (format "~a/wiki/~a" origin prefixed-category))
|
||||
|
||||
(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")))))
|
||||
(log-outgoing 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|headhtml|langlinks")
|
||||
("formatversion" . "2")
|
||||
("format" . "json")))))
|
||||
(log-outgoing dest-url)
|
||||
(define dest-res (easy:get dest-url #:timeouts timeouts))
|
||||
(easy:response-json dest-res)]
|
||||
[siteinfo (siteinfo-fetch wikiname)])
|
||||
(define-values (members-data page-data siteinfo)
|
||||
(thread-values
|
||||
(λ ()
|
||||
(define dest-url
|
||||
(format "~a/api.php?~a"
|
||||
origin
|
||||
(params->query `(("action" . "query")
|
||||
("list" . "categorymembers")
|
||||
("cmtitle" . ,prefixed-category)
|
||||
("cmlimit" . "max")
|
||||
("formatversion" . "2")
|
||||
("format" . "json")))))
|
||||
(log-outgoing dest-url)
|
||||
(define dest-res (easy:get dest-url #:timeouts timeouts))
|
||||
(easy:response-json dest-res))
|
||||
(λ ()
|
||||
(define dest-url
|
||||
(format "~a/api.php?~a"
|
||||
origin
|
||||
(params->query `(("action" . "parse")
|
||||
("page" . ,prefixed-category)
|
||||
("prop" . "text|headhtml|langlinks")
|
||||
("formatversion" . "2")
|
||||
("format" . "json")))))
|
||||
(log-outgoing dest-url)
|
||||
(define dest-res (easy:get dest-url #:timeouts timeouts))
|
||||
(easy:response-json dest-res))
|
||||
(λ ()
|
||||
(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 "")))
|
||||
(define page (html->xexp page-html))
|
||||
(define head-data ((head-data-getter wikiname) page-data))
|
||||
(define body (generate-results-page
|
||||
#:req req
|
||||
#:source-url source-url
|
||||
#:wikiname wikiname
|
||||
#:title title
|
||||
#:members-data members-data
|
||||
#:page page
|
||||
#:head-data head-data
|
||||
#:siteinfo siteinfo))
|
||||
(define title (preprocess-html-wiki (jp "/parse/title" page-data prefixed-category)))
|
||||
(define page-html (preprocess-html-wiki (jp "/parse/text" page-data "")))
|
||||
(define page (html->xexp page-html))
|
||||
(define head-data ((head-data-getter wikiname) page-data))
|
||||
(define body (generate-results-page
|
||||
#:req req
|
||||
#:source-url source-url
|
||||
#:wikiname wikiname
|
||||
#:title title
|
||||
#:members-data members-data
|
||||
#:page page
|
||||
#:head-data head-data
|
||||
#:siteinfo siteinfo))
|
||||
|
||||
(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
|
||||
#:headers (build-headers always-headers)
|
||||
(λ (out)
|
||||
(write-html body out))))))
|
||||
(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
|
||||
#:headers (build-headers always-headers)
|
||||
(λ (out)
|
||||
(write-html body out)))))
|
||||
(module+ test
|
||||
(check-not-false ((query-selector (attribute-selector 'href "/test/wiki/Ankle_Monitor")
|
||||
(generate-results-page
|
||||
|
|
|
|||
|
|
@ -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,42 +109,45 @@
|
|||
(define origin (format "https://~a.fandom.com" wikiname))
|
||||
(define source-url (format "~a/wiki/~a" origin prefixed-title))
|
||||
|
||||
(thread-let
|
||||
([media-detail (define dest-url
|
||||
(format "~a/wikia.php?~a"
|
||||
origin
|
||||
(params->query `(("format" . "json") ("controller" . "Lightbox")
|
||||
("method" . "getMediaDetail")
|
||||
("fileTitle" . ,prefixed-title)))))
|
||||
(log-outgoing dest-url)
|
||||
(define dest-res (easy:get dest-url #:timeouts timeouts))
|
||||
(easy:response-json dest-res)]
|
||||
[siteinfo (siteinfo-fetch wikiname)])
|
||||
(if (not (jp "/exists" media-detail #f))
|
||||
(next-dispatcher)
|
||||
(response-handler
|
||||
(define file-title (jp "/fileTitle" media-detail ""))
|
||||
(define title
|
||||
(if (non-empty-string? file-title) (format "File:~a" file-title) prefixed-title))
|
||||
(define image-content-type
|
||||
(if (non-empty-string? (jp "/videoEmbedCode" media-detail ""))
|
||||
#f
|
||||
(url-content-type (jp "/imageUrl" media-detail))))
|
||||
(define body
|
||||
(generate-results-page #:req req
|
||||
#:source-url source-url
|
||||
#:wikiname wikiname
|
||||
#:title title
|
||||
#:media-detail media-detail
|
||||
#:image-content-type image-content-type
|
||||
#:siteinfo siteinfo))
|
||||
(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
|
||||
#:headers (build-headers always-headers)
|
||||
(λ (out) (write-html body out))))))))
|
||||
(define-values (media-detail siteinfo)
|
||||
(thread-values
|
||||
(λ ()
|
||||
(define dest-url
|
||||
(format "~a/wikia.php?~a"
|
||||
origin
|
||||
(params->query `(("format" . "json") ("controller" . "Lightbox")
|
||||
("method" . "getMediaDetail")
|
||||
("fileTitle" . ,prefixed-title)))))
|
||||
(log-outgoing dest-url)
|
||||
(define dest-res (easy:get dest-url #:timeouts timeouts))
|
||||
(easy:response-json dest-res))
|
||||
(λ ()
|
||||
(siteinfo-fetch wikiname))))
|
||||
(if (not (jp "/exists" media-detail #f))
|
||||
(next-dispatcher)
|
||||
(response-handler
|
||||
(define file-title (jp "/fileTitle" media-detail ""))
|
||||
(define title
|
||||
(if (non-empty-string? file-title) (format "File:~a" file-title) prefixed-title))
|
||||
(define image-content-type
|
||||
(if (non-empty-string? (jp "/videoEmbedCode" media-detail ""))
|
||||
#f
|
||||
(url-content-type (jp "/imageUrl" media-detail))))
|
||||
(define body
|
||||
(generate-results-page #:req req
|
||||
#:source-url source-url
|
||||
#:wikiname wikiname
|
||||
#:title title
|
||||
#:media-detail media-detail
|
||||
#:image-content-type image-content-type
|
||||
#:siteinfo siteinfo))
|
||||
(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
|
||||
#:headers (build-headers always-headers)
|
||||
(λ (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")
|
||||
|
|
|
|||
|
|
@ -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,23 +73,26 @@
|
|||
("formatversion" . "2")
|
||||
("format" . "json")))))
|
||||
|
||||
(thread-let
|
||||
([dest-res (log-outgoing dest-url)
|
||||
(easy:get dest-url #:timeouts timeouts)]
|
||||
[siteinfo (siteinfo-fetch wikiname)])
|
||||
(define-values (dest-res siteinfo)
|
||||
(thread-values
|
||||
(λ ()
|
||||
(log-outgoing dest-url)
|
||||
(easy:get dest-url #:timeouts timeouts))
|
||||
(λ ()
|
||||
(siteinfo-fetch wikiname))))
|
||||
|
||||
(define data (easy:response-json dest-res))
|
||||
(define data (easy:response-json dest-res))
|
||||
|
||||
(define body (generate-results-page req dest-url wikiname query data #:siteinfo siteinfo))
|
||||
(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
|
||||
#:headers (build-headers always-headers)
|
||||
(λ (out)
|
||||
(write-html body out))))))
|
||||
(define body (generate-results-page req dest-url wikiname query data #:siteinfo siteinfo))
|
||||
(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
|
||||
#:headers (build-headers always-headers)
|
||||
(λ (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")
|
||||
|
|
|
|||
|
|
@ -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,59 +42,62 @@
|
|||
(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
|
||||
([dest-res (define dest-url
|
||||
(format "~a/api.php?~a"
|
||||
origin
|
||||
(params->query `(("action" . "parse")
|
||||
("page" . ,path)
|
||||
("prop" . "text|headhtml|langlinks")
|
||||
("formatversion" . "2")
|
||||
("format" . "json")))))
|
||||
(log-outgoing dest-url)
|
||||
(easy:get dest-url
|
||||
#:timeouts timeouts
|
||||
#:headers `#hasheq((cookie . ,(format "theme=~a" (user-cookies^-theme user-cookies)))))]
|
||||
[siteinfo (siteinfo-fetch wikiname)])
|
||||
(define-values (dest-res siteinfo)
|
||||
(thread-values
|
||||
(λ ()
|
||||
(define dest-url
|
||||
(format "~a/api.php?~a"
|
||||
origin
|
||||
(params->query `(("action" . "parse")
|
||||
("page" . ,path)
|
||||
("prop" . "text|headhtml|langlinks")
|
||||
("formatversion" . "2")
|
||||
("format" . "json")))))
|
||||
(log-outgoing dest-url)
|
||||
(easy:get dest-url
|
||||
#:timeouts timeouts
|
||||
#:headers `#hasheq((cookie . ,(format "theme=~a" (user-cookies^-theme user-cookies))))))
|
||||
(λ ()
|
||||
(siteinfo-fetch wikiname))))
|
||||
|
||||
(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)]
|
||||
[head-data ((head-data-getter wikiname) data)])
|
||||
(if (equal? "missingtitle" (jp "/error/code" data #f))
|
||||
(next-dispatcher)
|
||||
(response-handler
|
||||
(define body
|
||||
(generate-wiki-page
|
||||
(update-tree-wiki page wikiname)
|
||||
#:req req
|
||||
#:source-url source-url
|
||||
#:wikiname wikiname
|
||||
#:title title
|
||||
#:head-data head-data
|
||||
#:siteinfo siteinfo))
|
||||
(define redirect-msg ((query-selector (attribute-selector 'class "redirectMsg") body)))
|
||||
(define redirect-query-parameter (dict-ref (url-query (request-uri req)) 'redirect "yes"))
|
||||
(define headers
|
||||
(build-headers
|
||||
always-headers
|
||||
; redirect-query-parameter: only the string "no" is significant:
|
||||
; https://github.com/Wikia/app/blob/fe60579a53f16816d65dad1644363160a63206a6/includes/Wiki.php#L367
|
||||
(when (and redirect-msg
|
||||
(not (equal? redirect-query-parameter "no")))
|
||||
(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))])
|
||||
(header #"Refresh" value)))))
|
||||
(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
|
||||
#:headers headers
|
||||
(λ (out)
|
||||
(write-html body out))))))])))
|
||||
(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)]
|
||||
[head-data ((head-data-getter wikiname) data)])
|
||||
(if (equal? "missingtitle" (jp "/error/code" data #f))
|
||||
(next-dispatcher)
|
||||
(response-handler
|
||||
(define body
|
||||
(generate-wiki-page
|
||||
(update-tree-wiki page wikiname)
|
||||
#:req req
|
||||
#:source-url source-url
|
||||
#:wikiname wikiname
|
||||
#:title title
|
||||
#:head-data head-data
|
||||
#:siteinfo siteinfo))
|
||||
(define redirect-msg ((query-selector (attribute-selector 'class "redirectMsg") body)))
|
||||
(define redirect-query-parameter (dict-ref (url-query (request-uri req)) 'redirect "yes"))
|
||||
(define headers
|
||||
(build-headers
|
||||
always-headers
|
||||
; redirect-query-parameter: only the string "no" is significant:
|
||||
; https://github.com/Wikia/app/blob/fe60579a53f16816d65dad1644363160a63206a6/includes/Wiki.php#L367
|
||||
(when (and redirect-msg
|
||||
(not (equal? redirect-query-parameter "no")))
|
||||
(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))])
|
||||
(header #"Refresh" value)))))
|
||||
(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
|
||||
#:headers headers
|
||||
(λ (out)
|
||||
(write-html body out))))))]))
|
||||
|
|
|
|||
Loading…
Reference in a new issue