Migrate config.rkt to Typed Racket

I find prefix notation more natural to represent the type/kind of the thing.

src/config.rkt

@@ -1,23 +1,32 @@
-#lang racket/base
+#lang typed/racket/base
 (require racket/function
          racket/pretty
          racket/runtime-path
-         racket/string
-         ini)
+         racket/string)
+(require/typed ini
+  [#:opaque Ini ini?]
+  [read-ini (Input-Port -> Ini)]
+  [ini->hash (Ini -> (Immutable-HashTable Symbol (Immutable-HashTable Symbol String)))])
 
 (provide
  config-parameter
  config-true?
  config-get)
 
+(module+ test
+  (require "typed-rackunit.rkt"))
+
 (define-runtime-path path-config "../config.ini")
 
+(: config-parameter (Symbol -> (Parameterof String)))
 (define (config-parameter key)
   (hash-ref config key))
 
+(: config-true? (Symbol -> Boolean))
 (define (config-true? key)
   (not (member ((config-parameter key)) '("" "false"))))
 
+(: config-get (Symbol -> String))
 (define (config-get key)
   ((config-parameter key)))
 
@@ -26,6 +35,7 @@
     (canonical_origin . "")
     (debug . "false")
     (instance_is_official . "false") ; please don't turn this on, or you will make me very upset
+    (log_outgoing . "true")
     (port . "10416")
     (strict_proxy . "true")))
 
@@ -55,18 +65,24 @@
 
 (define env-alist
   (let ([e-names (environment-variables-names (current-environment-variables))]
-        [e-ref (λ (name) (bytes->string/latin-1 (environment-variables-ref (current-environment-variables) name)))])
-    (map (λ (name) (cons (string->symbol (string-downcase (substring (bytes->string/latin-1 name) 3)))
+        [e-ref (λ ([name : Bytes])
+                 (bytes->string/latin-1
+                  (cast (environment-variables-ref (current-environment-variables) name)
+                        Bytes)))])
+    (map (λ ([name : Bytes])
+           (cons (string->symbol (string-downcase (substring (bytes->string/latin-1 name) 3)))
                  (e-ref name)))
-         (filter (λ (name) (string-prefix? (string-downcase (bytes->string/latin-1 name)) "bw_")) e-names))))
+         (filter (λ ([name : Bytes]) (string-prefix? (string-downcase (bytes->string/latin-1 name))
+                                                     "bw_"))
+                 e-names))))
 (when (> (length env-alist) 0)
   (printf "note: ~a items loaded from environment variables~n" (length env-alist)))
 
 (define combined-alist (append default-config loaded-alist env-alist))
 
 (define config
-  (make-hasheq
-   (map (λ (pair)
+  (make-immutable-hasheq
+   (map (λ ([pair : (Pairof Symbol String)])
           (cons (car pair) (make-parameter (cdr pair))))
         combined-alist)))
 
@@ -74,8 +90,8 @@
   ; all values here are optimised for maximum prettiness
   (parameterize ([pretty-print-columns 80])
     (display "config: ")
-    (pretty-write (sort
-                   (hash->list (make-hasheq combined-alist))
+    (pretty-write ((inst sort (Pairof Symbol String))
+                   (hash->list (make-immutable-hasheq combined-alist))
                    symbol<?
                    #:key car))))
 
@@ -84,3 +100,10 @@
     (displayln
      (string-append "warning: configuring canonical_origin is highly recommended for production!\n"
                     "         see https://docs.breezewiki.com/Configuration.html"))))
+
+(module+ test
+  ; this is just a sanity check
+  (parameterize ([(config-parameter 'application_name) "JeffWiki"]
+                 [(config-parameter 'strict_proxy) ""])
+    (check-equal? (config-get 'application_name) "JeffWiki")
+    (check-false (config-true? 'strict_proxy))))

src/data.rkt

@@ -20,7 +20,7 @@
                              ("siprop" . "rightsinfo")
                              ("format" . "json")
                              ("formatversion" . "2")))))
-  (printf "out: ~a~n" dest-url)
+  (log-outgoing dest-url)
   (define res (easy:get dest-url))
   (define data (easy:response-json res))
   (license (jp "/query/rightsinfo/text" data)

src/dispatcher-tree.rkt

@@ -8,7 +8,8 @@
          (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
          (prefix-in lift: web-server/dispatchers/dispatch-lift)
          (prefix-in filter: web-server/dispatchers/dispatch-filter)
-         "config.rkt")
+         "config.rkt"
+         "url-utils.rkt")
 
 (provide
  ; syntax to make the hashmap from names
@@ -43,9 +44,9 @@
               (pathprocedure:make "/" (hash-ref ds 'page-home))
               (pathprocedure:make "/proxy" (hash-ref ds 'page-proxy))
               (pathprocedure:make "/search" (hash-ref ds 'page-global-search))
-              (filter:make #px"^/[a-zA-Z0-9-]{3,50}/wiki/Category:.+$" (lift:make (hash-ref ds 'page-category)))
-              (filter:make #px"^/[a-zA-Z0-9-]{3,50}/wiki/.+$" (lift:make (hash-ref ds 'page-wiki)))
-              (filter:make #px"^/[a-zA-Z0-9-]{3,50}/search$" (lift:make (hash-ref ds 'page-search)))
-              (filter:make #px"^/[a-zA-Z0-9-]{3,50}(/(wiki(/)?)?)?$" (lift:make (hash-ref ds 'redirect-wiki-home)))
+              (filter:make (pregexp (format "^/~a/wiki/Category:.+$" px-wikiname)) (lift:make (hash-ref ds 'page-category)))
+              (filter:make (pregexp (format "^/~a/wiki/.+$" px-wikiname)) (lift:make (hash-ref ds 'page-wiki)))
+              (filter:make (pregexp (format "^/~a/search$" px-wikiname)) (lift:make (hash-ref ds 'page-search)))
+              (filter:make (pregexp (format "^/~a(/(wiki(/)?)?)?$" px-wikiname)) (lift:make (hash-ref ds 'redirect-wiki-home)))
               (hash-ref ds 'static-dispatcher)
               (lift:make (hash-ref ds 'page-not-found)))))))

src/page-category.rkt

@@ -75,7 +75,7 @@
                                               ("cmlimit" . "max")
                                               ("formatversion" . "2")
                                               ("format" . "json")))))
-                   (printf "out: ~a~n" dest-url)
+                   (log-outgoing dest-url)
                    (define dest-res (easy:get dest-url #:timeouts timeouts))
                    (easy:response-json dest-res)]
      [page-data (define dest-url
@@ -86,7 +86,7 @@
                                            ("prop" . "text|headhtml|langlinks")
                                            ("formatversion" . "2")
                                            ("format" . "json")))))
-                (printf "out: ~a~n" dest-url)
+                (log-outgoing dest-url)
                 (define dest-res (easy:get dest-url #:timeouts timeouts))
                 (easy:response-json dest-res)]
      [license (license-auto wikiname)])

src/page-proxy.rkt

@@ -18,13 +18,16 @@
   (match (dict-ref (url-query (request-uri req)) 'dest #f)
     [(? string? dest)
      (if (is-fandom-url? dest)
-         (response-handler
+         (response-handler ; catches and reports errors
           (let ([dest-r (easy:get dest #:stream? #t)])
+            (with-handlers ([exn:fail? (λ (e) ; cleans up and re-throws
+                                         (easy:response-close! dest-r)
+                                         (raise e))])
               (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)
-               (easy:response-close! dest-r)))))
+                 (easy:response-close! dest-r))))))
          (next-dispatcher))]
     [#f (next-dispatcher)]))

src/page-search.rkt

@@ -68,7 +68,7 @@
                               ("format" . "json")))))
 
    (thread-let
-    ([dest-res (printf "out: ~a~n" dest-url)
+    ([dest-res (log-outgoing dest-url)
                (easy:get dest-url #:timeouts timeouts)]
      [license (license-auto wikiname)])
 

src/page-wiki.rkt

@@ -143,7 +143,7 @@
                        (λ (href)
                          ((compose1
                            (λ (href) (regexp-replace #rx"^(/wiki/.*)" href (format "/~a\\1" wikiname)))
-                           (λ (href) (regexp-replace #px"^https://([a-zA-Z0-9-]{3,50}).fandom.com(/wiki/.*)" href "/\\1\\2")))
+                           (λ (href) (regexp-replace (pregexp (format "^https://(~a)\\.fandom\\.com(/wiki/.*)" px-wikiname)) href "/\\1\\2")))
                           href)))
                 ; add noreferrer to a.image
                 (curry u
@@ -246,7 +246,7 @@
                                          ("prop" . "text|headhtml|langlinks")
                                          ("formatversion" . "2")
                                          ("format" . "json")))))
-              (printf "out: ~a~n" dest-url)
+              (log-outgoing dest-url)
               (easy:get dest-url #:timeouts timeouts)]
     [license (license-auto wikiname)])
 

src/url-utils.rkt

@@ -1,18 +1,25 @@
 #lang typed/racket/base
 (require racket/string
+         "config.rkt"
          "pure-utils.rkt")
 
 (provide
+ ; regex to match wiki names
+ px-wikiname
  ; 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?)
+ is-fandom-url?
+  ; prints "out: <url>"
+ log-outgoing)
 
 (module+ test
   (require "typed-rackunit.rkt"))
 
+(define px-wikiname "[a-zA-Z0-9-]{3,50}")
+
 ;; https://url.spec.whatwg.org/#urlencoded-serializing
 
 (define urlencoded-set '(#\! #\' #\( #\) #\~ ; urlencoded set
@@ -57,7 +64,7 @@
 
 (: is-fandom-url? (String -> Boolean))
 (define (is-fandom-url? url)
-  (regexp-match? #px"^https://static.wikia.nocookie.net/|^https://[a-zA-Z0-9-]{3,50}.fandom.com/" url))
+  (regexp-match? (pregexp (format "^https://static\\.wikia\\.nocookie\\.net/|^https://~a\\.fandom\\.com/" px-wikiname)) 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"))
@@ -69,3 +76,8 @@
    is-fandom-url?
    (λ ([v : String]) (string-append "/proxy?" (params->query `(("dest" . ,url)))))
    url))
+
+(: log-outgoing (String -> Void))
+(define (log-outgoing url-string)
+  (when (config-true? 'log_outgoing)
+    (printf "out: ~a~n" url-string)))