Display correct license information

src/application-globals.rkt

@@ -4,6 +4,7 @@
          html-writing
          web-server/http
          "config.rkt"
+         "data.rkt"
          "xexpr-utils.rkt"
          "url-utils.rkt")
 
@@ -23,7 +24,8 @@
 
 (define timeouts (easy:make-timeout-config #:lease 5 #:connect 5))
 
-(define (application-footer source-url)
+(define (application-footer source-url #:license [license-in #f])
+  (define license (or license-in license-default))
   `(footer (@ (class "custom-footer"))
            (div (@ (class ,(if source-url "custom-footer__cols" "internal-footer")))
                 (div (p
@@ -46,8 +48,8 @@
                 ,(if source-url
                      `(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), "
+                              ,(format ". Text content is available under the ~a license, " (license-text license))
-                              (a (@ (href "https://www.fandom.com/licensing")) "see license info.")
+                              (a (@ (href ,(license-url license))) "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))))
                      `(div (p "Text content on wikis run by Fandom is available under the Creative Commons Attribution-Share Alike License 3.0 (Unported), "
@@ -60,8 +62,9 @@
          #:source-url source-url
          #:wikiname wikiname
          #:title title
-         #:body-class [body-class-in ""])
+         #:body-class [body-class-in #f]
-  (define body-class (if (equal? "" body-class-in)
+         #:license [license #f])
+  (define body-class (if (not body-class-in)
                          "skin-fandomdesktop"
                          body-class-in))
   (define (required-styles origin)
@@ -98,7 +101,7 @@
                           (div (@ (id "content") #;(class "page-content"))
                                (div (@ (id "mw-content-text"))
                                     ,content))
-                          ,(application-footer source-url)))))))
+                          ,(application-footer source-url #:license license)))))))
 (module+ test
   (define page
     (parameterize ([(config-parameter 'strict_proxy) "true"])

src/data.rkt

@@ -0,0 +1,33 @@
+#lang racket/base
+(require (prefix-in easy: net/http-easy)
+         "url-utils.rkt"
+         "xexpr-utils.rkt")
+
+(provide
+ (struct-out license)
+ license-default
+ license-auto)
+
+(struct license (text url) #:transparent)
+(define license-default (license "CC-BY-SA" "https://www.fandom.com/licensing"))
+(define license-hash (make-hash))
+(define (license-fetch wikiname)
+  (define dest-url
+    (format "https://~a.fandom.com/api.php?~a"
+            wikiname
+            (params->query '(("action" . "query")
+                             ("meta" . "siteinfo")
+                             ("siprop" . "rightsinfo")
+                             ("format" . "json")
+                             ("formatversion" . "2")))))
+  (printf "out: ~a~n" dest-url)
+  (define res (easy:get dest-url))
+  (define data (easy:response-json res))
+  (license (jp "/query/rightsinfo/text" data)
+           (jp "/query/rightsinfo/url" data)))
+(define (license-auto wikiname)
+  (if (hash-has-key? license-hash wikiname)
+      (hash-ref license-hash wikiname)
+      (let ([result (license-fetch wikiname)])
+        (hash-set! license-hash wikiname result)
+        result)))

src/dispatcher-tree.rkt

@@ -12,7 +12,9 @@
 
 (provide
  ; syntax to make the hashmap from names
- dispatcher-tree)
+ dispatcher-tree
+ ; procedure to make the tree from the hashmap
+ make-dispatcher-tree)
 
 ; make a hashmap out of the provided names and call make-dispatcher-tree with it
 (define-syntax (dispatcher-tree stx)

src/page-category.rkt

@@ -14,6 +14,7 @@
          #;(only-in web-server/http/redirect redirect-to)
          "application-globals.rkt"
          "config.rkt"
+         "data.rkt"
          "page-wiki.rkt"
          "syntax.rkt"
          "url-utils.rkt"
@@ -33,13 +34,15 @@
          #:prefixed-category prefixed-category
          #:members-data members-data
          #:page page
-         #:body-class body-class)
+         #:body-class [body-class #f]
+         #:license [license #f])
   (define members (jp "/query/categorymembers" members-data))
   (generate-wiki-page
    #:source-url source-url
    #:wikiname wikiname
    #:title prefixed-category
    #:body-class body-class
+   #:license license
    `(div
      ,(update-tree-wiki page wikiname)
      (hr)
@@ -85,7 +88,8 @@
                                            ("format" . "json")))))
                 (printf "out: ~a~n" dest-url)
                 (define dest-res (easy:get dest-url #:timeouts timeouts))
-                (easy:response-json dest-res)])
+                (easy:response-json dest-res)]
+     [license (license-auto wikiname)])
 
     (define page-html (preprocess-html-wiki (jp "/parse/text" page-data "")))
     (define page (html->xexp page-html))
@@ -93,15 +97,14 @@
     (define body-class (match (regexp-match #rx"<body [^>]*class=\"([^\"]*)" head-html)
                          [(list _ classes) classes]
                          [_ ""]))
-    (println head-html)
-    (println body-class)
     (define body (generate-results-page
                   #:source-url source-url
                   #:wikiname wikiname
                   #:prefixed-category prefixed-category
                   #:members-data members-data
                   #:page page
-                  #:body-class body-class))
+                  #:body-class body-class
+                  #:license license))
 
     (when (config-true? 'debug)
       ; used for its side effects
@@ -117,5 +120,5 @@
                                      #:source-url ""
                                      #:wikiname "test"
                                      #:prefixed-category "Category:Items"
-                                     #:category-data category-json-data
+                                     #:members-data category-json-data
                                      #:page '(div "page text"))))))

src/page-search.rkt

@@ -10,8 +10,10 @@
          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"
+         "data.rkt"
+         "syntax.rkt"
          "url-utils.rkt"
          "xexpr-utils.rkt")
 
@@ -23,12 +25,13 @@
   (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 (generate-results-page dest-url wikiname query data #:license [license #f])
   (define search-results (jp "/query/search" data))
   (generate-wiki-page
    #:source-url dest-url
    #:wikiname wikiname
    #:title "Search Results"
+   #:license license
    `(div (@ (class "mw-parser-output"))
          (p ,(format "~a results found for " (length search-results))
             (strong ,query))
@@ -54,21 +57,24 @@
   (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"
+   (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))
+   (thread-let
+    ([dest-res (printf "out: ~a~n" dest-url)
+               (easy:get dest-url #:timeouts timeouts)]
+     [license (license-auto wikiname)])
 
     (define data (easy:response-json dest-res))
 
-   (define body (generate-results-page dest-url wikiname query data))
+    (define body (generate-results-page dest-url wikiname query data #:license license))
     (when (config-true? 'debug)
       ; used for its side effects
       ; convert to string with error checking, error will be raised if xexp is invalid
@@ -76,7 +82,7 @@
     (response/output
      #:code 200
      (λ (out)
-      (write-html body 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

@@ -16,7 +16,9 @@
          ; my libs
          "application-globals.rkt"
          "config.rkt"
+         "data.rkt"
          "pure-utils.rkt"
+         "syntax.rkt"
          "xexpr-utils.rkt"
          "url-utils.rkt")
 
@@ -235,7 +237,9 @@
   (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"
+  (thread-let
+   ([dest-res (define dest-url
+                (format "~a/api.php?~a"
                         origin
                         (params->query `(("action" . "parse")
                                          ("page" . ,path)
@@ -243,7 +247,8 @@
                                          ("formatversion" . "2")
                                          ("format" . "json")))))
               (printf "out: ~a~n" dest-url)
-  (define dest-res (easy:get dest-url #:timeouts timeouts))
+              (easy:get dest-url #:timeouts timeouts)]
+    [license (license-auto wikiname)])
 
    (cond
      [(eq? 200 (easy:response-status-code dest-res))
@@ -265,7 +270,8 @@
                 #:source-url source-url
                 #:wikiname wikiname
                 #:title title
-               #:body-class body-class))
+                #:body-class body-class
+                #:license license))
              (define redirect-msg ((query-selector (attribute-selector 'class "redirectMsg") body)))
              (define headers (if redirect-msg
                                  (let* ([dest (get-attribute 'href (bits->attributes ((query-selector (λ (t a c) (eq? t 'a)) redirect-msg))))]
@@ -280,4 +286,4 @@
               #:code 200
               #:headers headers
               (λ (out)
-               (write-html body out))))))]))
+                (write-html body out))))))])))