server.rkt

   1 #lang racket
   2
   3 (require json)
   4 (require net/url)
   5 (require web-server/formlets)
   6 (require web-server/servlet)
   7 (require web-server/servlet-env)
   8 (require web-server/templates)
   9
  10 (require "blacklist.rkt")
  11
  12 (define (member-match? itm lst)
  13   (ormap (lambda (i) (regexp-match? (regexp i) itm)) lst))
  14
  15 (define-values (dispatch generate-url)
  16   (dispatch-rules
  17     [("") do-index]
  18     [("search") do-search]
  19     ))
  20
  21 (define (do-head title)
  22   (include-template "templates/head.html"))
  23
  24 (define (do-footer)
  25   (include-template "templates/footer.html"))
  26
  27 (define (do-index req)
  28   (http-response (string-append
  29                    (do-head "Web Search")
  30                    (include-template "templates/index.html")
  31                    (do-footer))))
  32
  33 (define (search query)
  34   (define engine (string->url
  35                    (string-append
  36                      "https://search.trom.tf/search?format=json&q=" query)))
  37   (define response (get-pure-port engine))
  38   (define json-raw (port->string response))
  39   (close-input-port response)
  40   (with-input-from-string json-raw (lambda () (read-json))))
  41
  42 (define (http-response content)  ; The 'content' parameter should be a string.
  43   (response/full
  44     200                  ; HTTP response code.
  45     #"OK"                ; HTTP response message.
  46     (current-seconds)    ; Timestamp.
  47     TEXT/HTML-MIME-TYPE  ; MIME type for content.
  48     '()                  ; Additional HTTP heads.
  49     (list                ; Content (in bytes) to send to the browser.
  50       (string->bytes/utf-8 content))))
  51
  52 (define (do-search req)
  53   (define binds (request-bindings req))
  54   (define query (if (exists-binding? 'q binds)
  55                   (extract-binding/single 'q binds)
  56                   ""))
  57
  58   (if (non-empty-string? query)
  59     (let ()
  60       (define results
  61         (foldr cons '()
  62                (filter hash?
  63                (map (lambda (i)
  64                       (define result-host
  65                         (url-host (string->url
  66                                     (hash-ref i 'url ""))))
  67                           (define result-url (hash-ref i 'url ""))
  68                           (define result-title (hash-ref i 'title ""))
  69                           (define result-content (hash-ref i 'content ""))
  70                         (define ht (make-hash))
  71                         (unless (member-match? result-host blacklist)
  72                           (let ()
  73                             (hash-set! ht "title" result-title)
  74                             (hash-set! ht "url" result-url)
  75                             (hash-set! ht "content" result-content)
  76                             )
  77                           ht
  78                       ))
  79                     (hash-ref (search query) 'results)))))
  80       (http-response (string-append
  81                        (do-head (string-append query " | Web Search"))
  82                        (include-template "templates/search.html")
  83                        (do-footer))))
  84     (redirect-to "/")))
  85
  86 (serve/servlet dispatch
  87                #:command-line? #t
  88                #:servlet-regexp #rx""
  89                #:extra-files-paths (list (build-path "./static")))