cobra
/
MeMe
1
1
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Photo list pages 

Signed-off-by: Skylar "The Cobra" Widulski <cobra@vern.cc>
This commit is contained in:
Skylar "The Cobra" Widulski 2023-12-07 09:07:43 -05:00
parent 35a58e6c55
commit 133ccc7c4f
Signed by: cobra
GPG Key ID: 4FD8F812083FF6F9
5 changed files with 171 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
meme.scm
View File

@ -33,10 +33,12 @@
(split-and-decode-uri-path
(uri-path
(request-uri request)))))
(display (string-append
(strftime "%c" (localtime (current-time)))
": " (uri->string uri)))
(newline)
(cond
((equal? path "/style.css")
(values '((content-type . (text/css)))
@ -49,18 +51,24 @@
((or (equal? path "/")
(equal? (car path-components) "page"))
(newsfeed-page path))
((or (equal? (cdr (last-pair path-components)) "photos")
(and (equal? (list-ref
((or (equal? (car (last-pair path-components)) "photos")
(and (>= (length path-components) 3)
(equal? (list-ref
path-components
(- (length path-components) 3))
"photos")
(equal? (list-ref
path-components
(- (length path-components) 2))))
(equal? (list-ref
path-components
(- (length path-components) 2))
"photos"))
(and (>= (length path-components) 2)
(equal? (list-ref
path-components
(- (length path-components) 2))
"photos")
(not (> (string-count
(car (last-pair path-components))
char-set:digit 0 1)
0))))
(photos-page path))
((equal? (car path-components) "memes")
(meme-page path))

78
meme/libxml2.scm
View File

@ -35,13 +35,16 @@
child1
props
name
doc
nodeset
nodeset-nodes
floatval
strval
dump-xpath-xml
dump-xml
get-xpath
dump-xpath-xml
get-xpath-string
get-xpath-nodeset
get-xpath-node))
(define libxml2 (dynamic-link "libxml2"))
@ -146,9 +149,11 @@
(next (child ptr) 0)
(child1 (next (child ptr) 0) (- times 1))))
(define (props ptr)
(list-ref (parse-c-struct ptr xml-node) 13))
(list-ref (parse-c-struct ptr xml-node) 11))
(define (name ptr)
(pointer->string (caddr (parse-c-struct ptr xml-node))))
(define (doc ptr)
(list-ref (parse-c-struct ptr xml-node) 8))
(define (nodeset ptr)
(cadr (parse-c-struct ptr xml-xpath-object)))
@ -168,56 +173,31 @@
(xml-free-doc doc)
content)
(define (dump-xpath-xml xpath body)
(define (get-xpath xpath body)
(define doc (gumbo-libxml-parse
(string->pointer body)))
(define context (xml-xpath-new-context doc))
(define object
(xml-xpath-eval-expression
(string->pointer xpath)
context))
(define buffer (xml-buffer-create))
(define nodes (nodeset-nodes (nodeset object)))
(define size (xml-node-dump buffer doc nodes 0 1))
(define content (pointer->string (car (parse-c-struct buffer xml-buffer))))
(xml-xpath-free-object object)
(xml-xpath-free-context context)
(xml-free-doc doc)
content)
(xml-xpath-eval-expression
(string->pointer xpath)
context))
(define (get-xpath-string xpath body attr)
(define doc (gumbo-libxml-parse
(string->pointer body)))
(define context (xml-xpath-new-context doc))
(define object
(xml-xpath-eval-expression
(string->pointer xpath)
context))
(define str
(pointer->string
(xml-node-list-get-string
doc
(if attr
(child (nodeset-nodes
(nodeset object)))
(nodeset-nodes
(nodeset object)))
1)))
(xml-xpath-free-object object)
(xml-xpath-free-context context)
(xml-free-doc doc)
str)
(define (dump-xpath-xml xpath body)
(define buffer (xml-buffer-create))
(define nodes (get-xpath-node xpath body))
(define size (xml-node-dump buffer (doc nodes) nodes 0 1))
(pointer->string (car (parse-c-struct buffer xml-buffer))))
(define (get-xpath-string xpath body attr?)
(pointer->string
(xml-node-list-get-string
(doc (get-xpath-node xpath body))
(if attr?
(child (get-xpath-node xpath body))
(get-xpath-node xpath body))
1)))
(define (get-xpath-nodeset xpath body)
(nodeset (get-xpath xpath body)))
(define (get-xpath-node xpath body)
(define doc (gumbo-libxml-parse
(string->pointer body)))
(define context (xml-xpath-new-context doc))
(define object
(xml-xpath-eval-expression
(string->pointer xpath)
context))
(define node (nodeset-nodes (nodeset object)))
;(xml-xpath-free-object object)
;(xml-xpath-free-context context)
;(xml-free-doc doc)
node)
(nodeset-nodes (get-xpath-nodeset xpath body)))

86
meme/scraping.scm
View File

@ -226,9 +226,7 @@
(cond
((and (equal? (name chld1) "a")
(equal? (name (child chld1)) "img"))
(set! chld2 (list-ref (parse-c-struct (child chld1)
xml-node)
11))
(set! chld2 (props (child chld1)))
(while (not (null-pointer? chld2))
(cond
((equal? (name chld2) "data-src")
@ -240,9 +238,7 @@
(proxy
(pointer->string
(xml-node-list-get-string
(list-ref
(parse-c-struct chld2 xml-node)
8)
(doc chld2)
(child chld2)
1)))
"\" />")))
@ -266,7 +262,81 @@
(cdr lst)))
(define (get-photos body)
(list))
(define gallery
(get-xpath-node
"//*[@id=\"photo_gallery\"]"
body))
(define lst (list ""))
(define pair '(() . ()))
(define chld (child1 gallery 0))
(define chld1 %null-pointer)
(define chld2 %null-pointer)
(define chld3 %null-pointer)
(define chld4 %null-pointer)
(while (not (null-pointer? chld))
(cond
((equal? (name chld) "div")
(set! chld1 (props chld))
(while (not (null-pointer? chld1))
(cond
((and (equal? (name chld1) "class")
(equal?
(pointer->string
(xml-node-list-get-string
(doc chld1)
(child chld1)
1))
"item"))
(set! chld2 (child1 chld 0))
(set! chld3 (props chld2))
(while (not (null-pointer? chld3))
(cond
((equal? (name chld3) "href")
(set-car!
pair
(pointer->string
(xml-node-list-get-string
(doc chld3)
(child chld3)
1)))
(break)))
(set! chld3 (next chld3 0)))
(set! chld4 (props (child1 chld2 0)))
(while (not (null-pointer? chld4))
(cond
((equal? (name chld4) "data-src")
(set-cdr!
pair
(pointer->string
(xml-node-list-get-string
(doc chld4)
(child chld4)
1)))
(break)))
(set! chld4 (next chld4 0)))
(append!
lst
(list
(cons (car pair)
(cdr pair))))))
(set! chld1 (next chld1 0)))))
(set! chld (next chld 0)))
(append
(list
(dump-xpath-xml "/html/body/div[3]/div/div[1]/header/hgroup/h1" body)
(if (null-pointer?
(caddr (parse-c-struct
(get-xpath-nodeset
"/html/body/div[3]/div/div[1]/header/hgroup/p"
body)
xml-nodeset)))
""
(get-xpath-string
"/html/body/div[3]/div/div[1]/header/hgroup/p/text()"
body #f))
(dump-xpath-xml "/html/body/div[3]/div/nav/ul" body)
(dump-xpath-xml "/html/body/div[3]/div/div[3]" body))
(cdr lst)))
(define (get-sidebar-gallery body)
(define gallery (list ""))
@ -455,4 +525,4 @@
body #t)))
(define (get-pagination body)
(dump-xpath-xml "/html/body/div[3]/div/div[4]/div" body))
(dump-xpath-xml "//div[@class=\"pagination\"]" body))

21
meme/templates.scm
View File

@ -24,7 +24,8 @@
#:use-module (system foreign)
#:export (error-template
newsfeed-template
meme-template))
meme-template
photos-template))
(define (kym->local url)
(if (>= (string-length url) 24)
@ -175,6 +176,22 @@
s "https://knowyourmeme.com" "")))
(list-tail meme 5)))))
(define (photos-as-sxml photos)
`(div
(div (@ (class "box photos"))
,(html->shtml (car photos))
(p ,(cadr photos))
,(html->shtml (caddr photos))
,(html->shtml (string-replace-substring
(cadddr photos)
"https://knowyourmeme.com"
"")))
(div (@ (class "box photos-gallery"))
,(map (lambda (p)
`(a (@ (href ,(car p)))
(img (@ (src ,(proxy (cdr p)))))))
(cddddr photos)))))
(define (sidebar-gallery-as-sxml sidebar-gallery)
(map (lambda (l)
`(div (@ (class "sidebar box"))
@ -299,4 +316,6 @@
(body
,heading
,(photos-as-sxml (get-photos body))
(div (@ (class "wide-pagination"))
,(pagination-as-sxml (get-pagination body)))
,footer))))

30
static/style.css
View File

@ -59,6 +59,11 @@ a {
width: 100%;
}
.wide-pagination {
margin: 1% 1% -4% 1%;
width: 92.5%;
}
.trending.box,
.leaderboard.box,
.heading.box,
@ -240,3 +245,28 @@ div.references p {
margin-bottom: 0;
float: left;
}
.photos.box {
width: 93%;
padding: 0 2%;
}
.photos.box ul li {
display: inline;
margin-right: 1em;
}
.photos.box ul li ul,
.photos.box div#photo_gallery {
display: none;
}
.photos-gallery.box {
width: 87%;
padding: 1% 5%;
}
.photos-gallery.box img {
margin: 0.5em;
max-height: 15em;
}