#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))))))]))