152 lines
5.4 KiB
Scheme
152 lines
5.4 KiB
Scheme
;; Copyright (C) 2024 Skylar Widulski <cobra@vern.cc>
|
|
;;
|
|
;; This file is part of MeMe
|
|
;;
|
|
;; MeMe is free software: you can redistribute it and/or modify it under the
|
|
;; terms of the GNU Affero General Public License as published by the Free
|
|
;; Software Foundation, either version 3 of the License, or (at your option) any
|
|
;; later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful, but WITHOUT
|
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License
|
|
;; for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Affero General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
(define-module (meme pages)
|
|
#:use-module (meme templates)
|
|
#:use-module (libxml2)
|
|
#:use-module (web response)
|
|
#:use-module (web client)
|
|
#:use-module (web http)
|
|
#:use-module (web uri)
|
|
#:use-module (ice-9 receive)
|
|
#:use-module (system foreign)
|
|
#:export (pages?
|
|
error-page
|
|
articles-page
|
|
meme-page
|
|
meme-list-page
|
|
category-list-page
|
|
photos-page
|
|
photo-page
|
|
videos-page
|
|
proxy-page))
|
|
|
|
(define base-url "https://knowyourmeme.com")
|
|
|
|
(define (pages? components str)
|
|
(or (equal? (car (last-pair components)) str)
|
|
(and (equal? (list-ref components (- (length components) 2)) "page")
|
|
(equal? (list-ref components (- (length components) 3)) str))))
|
|
|
|
(define good-response
|
|
(build-response #:code 200
|
|
#:headers `((content-type . (text/html)))))
|
|
|
|
(define (redirect response code)
|
|
(values (build-response #:code code
|
|
#:headers `((location . ,(parse-header
|
|
'location
|
|
(uri-path
|
|
(response-location
|
|
response))))))
|
|
"Redirect"))
|
|
|
|
(define (error-page code)
|
|
(values (build-response
|
|
#:code code
|
|
#:headers `((content-type . (text/html)))) (error-template code)))
|
|
|
|
(define (generic-page procedure path)
|
|
(let ((resp "")
|
|
(body "")
|
|
(d %null-pointer)
|
|
(ret ""))
|
|
(receive (_resp _body) (http-request (string-append base-url path))
|
|
(set! resp _resp)
|
|
(set! body _body))
|
|
(display (string-append ";\tStatus: "
|
|
(number->string (response-code resp))))
|
|
(newline)
|
|
(cond ((equal? (response-code resp) 200)
|
|
(set! d (gumbo-libxml-parse (string->pointer body)))
|
|
(set! ret (procedure d))
|
|
(xml-free-doc d)
|
|
(values good-response ret))
|
|
((and (>= (response-code resp) 300) (<= (response-code resp) 399))
|
|
(redirect resp (response-code resp)))
|
|
(else (error-page (response-code resp))))))
|
|
|
|
(define (articles-page path)
|
|
(display ";\tHandler: articles-page")
|
|
(generic-page articles-template path))
|
|
|
|
(define (meme-page path)
|
|
(display ";\tHandler: meme-page")
|
|
(generic-page meme-template path))
|
|
|
|
(define (meme-list-page path)
|
|
(display ";\tHandler: meme-list-page")
|
|
(generic-page meme-list-template path))
|
|
|
|
(define (category-list-page path)
|
|
(display ";\tHandler: category-list-page")
|
|
(generic-page category-list-template path))
|
|
|
|
(define (photos-page path)
|
|
(display ";\tHandler: photos-page")
|
|
(generic-page photos-template path))
|
|
|
|
(define (photo-page path)
|
|
(display ";\tHandler: photo-page")
|
|
(generic-page photo-template path))
|
|
|
|
(define (videos-page path)
|
|
(display ";\tHandler: videos-page")
|
|
(generic-page videos-template path))
|
|
|
|
(define (proxy-page query)
|
|
(display ";\tHandler: proxy-page") (newline)
|
|
(let ((resp "")
|
|
(body "")
|
|
(url ""))
|
|
(map (lambda (p)
|
|
(if (equal? (car p) "url")
|
|
(set! url (cadr p))))
|
|
(map (lambda (s)
|
|
(string-split s #\=))
|
|
(string-split query #\&)))
|
|
(if (or (equal? (substring url 0 22) "https://i.kym-cdn.com/")
|
|
(equal? (substring url 0 20) "https://i.ytimg.com/")
|
|
(equal? (substring url 0 22) "https://a.kym-cdn.com/"))
|
|
(begin
|
|
(receive (_resp _body) (http-request url)
|
|
(set! resp _resp)
|
|
(set! body _body))
|
|
(cond
|
|
((equal? (response-code resp) 200)
|
|
(values (build-response
|
|
#:code 200
|
|
#:headers `((content-type .
|
|
,(response-content-type resp))
|
|
(cache-control .
|
|
,(parse-header 'cache-control
|
|
"max-age=604800"))))
|
|
body))
|
|
((and (>= (response-code resp) 300) (<= (response-code resp) 399))
|
|
(values (build-response
|
|
#:code code
|
|
#:headers `((location . ,(parse-header
|
|
'location
|
|
(uri-path
|
|
(response-location
|
|
response))))
|
|
(content-type .
|
|
,(response-content-type resp))))
|
|
"Redirect"))
|
|
(else (error-page 404))))
|
|
(error-page 400))))
|