#!/usr/local/bin/guile -s !# (use-modules (web server) (web request) (web response) (web uri) (sxml simple) (web client) (rnrs bytevectors) (srfi srfi-11) (srfi srfi-1) (ice-9 match) (json) (texinfo) (texinfo plain-text) (apps aux strings) (apps base templates theme) (apps base utils) (apps base types) (apps base templates components)) (define (templatize title body) `(html (head (title ,title)) (body ,@body))) (define* (respond #:optional body #:key (status 200) (title "Packages") (doctype "\n") (content-type-params '((charset . "utf-8"))) (content-type 'text/html) (extra-headers '()) (sxml (and body (templatize title body)))) (values (build-response #:code status #:headers `((content-type . (,content-type ,@content-type-params)) ,@extra-headers)) (lambda (port) (if sxml (begin (if doctype (display doctype port)) (sxml->xml sxml port)))))) (define (search-packages-page request body) (define uri-value (let ((uri (request-uri request))) (if (eqv? #f (uri-query uri)) "" (second (string-split (uri-query uri) #\=))))) (define response (let-values (((response-object body) (http-request (string-append "http://data.guix.gnu.org/repository/1/branch/master/latest-processed-revision/packages.json?locale=en_US.utf8&search_query=" uri-value "&field=version&field=synopsis&field=description&after_name=&limit_results=30") #:method 'GET))) (json-string->scm (utf8->string body)))) (respond `((link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/package.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/item-preview.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/page.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/elements.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/common.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/messages.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/navbar.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/breadcrumbs.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/buttons.css"))) (link (@ (rel "stylesheet") (href "http://guix-website-test.cbaines.net/static/base/css/footer.css"))) (link (@ (rel "stylesheet") (href "https://stackpath.bootstrapcdn.com/bootstrap/3.4.1/css/bootstrap.min.css") (integrity "sha384-HSMxcRTRxnN+Bdg0JdbxYKrThecOKuH5zCYotlSAcp1+c8xmyTe9GYg1l9a69psu") (crossorigin "anonymous"))) ,(navbar #:active-item "packages/search") (div (@ (class "package-info")) (div (@ (class "search-container") (style "display: block; text-align: center;")) (h1 "Packages") (form (@ (style "display: inline-block; margin-right auto; text-align: left")) (input (@ (type "text") (placeholder "Search packages") (name "search"))) (button (@ (class "btn btn-primary pull-right") (type "submit")) '((span (@ (class "glyphicon glyphicon-search") (aria-hidden "true"))))))) ,@(match response ((packages _) (map (match-lambda ((description synopsis version name) (let ((package-name (cdr name)) (package-version (cdr version)) (package-synopsis (match synopsis ((synopsis locale plain html source) (cdr source)))) (package-description (match description ((description locale plain html source) (cdr source))))) `(a (@ (class "item-preview") (href ,(string-append "http://guix-website-test.cbaines.net/packages/" (string-append package-name "-" package-version)))) (h3 ,package-name " " ,package-version) (p (@ (class "item-summary")) ,(string-summarize (stexi->plain-text (texi-fragment->stexi package-description)) 30) "…"))))) (vector->list (cdr packages)))))) (footer "Made with " (span (@ (class "metta")) "♥") " by humans and powered by " (a (@ (class "link-yellow") (href ,(gnu-url "software/guile/"))) "GNU Guile") ". " (a (@ (class "link-yellow") (href "//git.savannah.gnu.org/cgit/guix/guix-artwork.git/tree/website")) "Source code") " under the " (a (@ (class "link-yellow") (href ,(gnu-url "licenses/agpl-3.0.html"))) "GNU AGPL") ".")))) (run-server search-packages-page 'http '(#:port 8765))