diff options
| -rw-r--r-- | README.md | 3 | ||||
| -rw-r--r-- | neocities.scm | 4 | ||||
| -rw-r--r-- | neocities/api.scm | 98 | ||||
| -rw-r--r-- | neocities/mime.scm | 153 | ||||
| -rw-r--r-- | neocities/requests.scm | 132 |
5 files changed, 390 insertions, 0 deletions
diff --git a/README.md b/README.md new file mode 100644 index 0000000..fd5304a --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# Guile Neocities + +Guile library for [Neocities API](https://neocities.org/api). diff --git a/neocities.scm b/neocities.scm new file mode 100644 index 0000000..7369559 --- /dev/null +++ b/neocities.scm @@ -0,0 +1,4 @@ +(define-module (neocities) + #:use-module (neocities api) + #:export () + ) diff --git a/neocities/api.scm b/neocities/api.scm new file mode 100644 index 0000000..9a7de10 --- /dev/null +++ b/neocities/api.scm @@ -0,0 +1,98 @@ +(define-module (neocities api) + #:use-module (neocities requests) + #:use-module (rnrs base) + #:use-module (srfi srfi-9) + #:export ( + make-neocities-api + make-neocities-auth-basic + make-neocities-auth-api-key + neocities-delete + neocities-info + neocities-list + neocities-key + neocities-upload +)) + +(define-record-type <neocities-auth-api-key> + (make-neocities-auth-api-key key) + neocities-auth-api-key? + (key neocities-auth-api-key)) + +(define-record-type <neocities-auth-basic> + (make-neocities-auth-basic username password) + neocities-auth-basic? + (username neocities-auth-basic-username) + (password neocities-auth-basic-password)) + +(define (encode-auth auth) + (cond + ((neocities-auth-api-key? auth) + (encode-bearer-auth-header (neocities-auth-api-key auth))) + ((neocities-auth-basic? auth) + (encode-basic-auth-header + (neocities-auth-basic-username auth) + (neocities-auth-basic-password auth))) + (else + (throw 'neocities "Authentication scheme not supported")))) + +(define-record-type <neocities-api> + (make-neocities-api hostname auth) + neocities-api? + (hostname neocities-api-hostname) + (auth neocities-api-auth neocities-api-auth-set!)) + + + +(define* (neocities-delete api files) + (when (not (list? files)) + (throw 'neocities "files to delete must be a list")) + + (let ((url (neocities-url "delete" + #:hostname (neocities-api-hostname api) + #:querystring `(("files" . ,files))))) + (neocities-request + 'POST + url + #:auth (encode-auth (neocities-api-auth api))))) + + +(define* (neocities-list api #:optional path) + (let ((url (neocities-url "list" + #:hostname (neocities-api-hostname api) + #:querystring (if path `(("path" ,path)) '())))) + (neocities-request + 'GET + url + #:auth (encode-auth (neocities-api-auth api))))) + +(define* (neocities-info api #:optional sitename) + ;; It can be unauthenticated, but this is only the authenticated version + (let ((url (neocities-url "info" + #:hostname (neocities-api-hostname api) + #:querystring (if sitename + `(("sitename" ,sitename)) + '())))) + (neocities-request + 'GET + url + #:auth (encode-auth (neocities-api-auth api))))) + +(define* (neocities-key api) + (let ((url (neocities-url "key" + #:hostname (neocities-api-hostname api)))) + (neocities-request + 'GET + url + #:auth (encode-auth (neocities-api-auth api))))) + +(define* (neocities-upload api files) + "files is an alist with the filename and destination" + (let ((url (neocities-url "upload" + #:hostname (neocities-api-hostname api)))) + (let-values (((boundary body) (encode-multipart-body files))) + (neocities-request + 'POST + url + #:content-type (string-append "multipart/form-data; boundary=" boundary) + #:body body + #:auth (encode-auth (neocities-api-auth api)))))) diff --git a/neocities/mime.scm b/neocities/mime.scm new file mode 100644 index 0000000..b6391d4 --- /dev/null +++ b/neocities/mime.scm @@ -0,0 +1,153 @@ +(define-module (neocities mime) + #:export (mime-types)) + +(define mime-types + '(("js" . "application/javascript") + ("mjs" . "application/javascript") + ("json" . "application/json") + ("webmanifest". "application/manifest+json") + ("doc" . "application/msword") + ("dot" . "application/msword") + ("wiz" . "application/msword") + ("nq" . "application/n-quads") + ("nt" . "application/n-triples") + ("bin" . "application/octet-stream") + ("a" . "application/octet-stream") + ("dll" . "application/octet-stream") + ("exe" . "application/octet-stream") + ("o" . "application/octet-stream") + ("obj" . "application/octet-stream") + ("so" . "application/octet-stream") + ("oda" . "application/oda") + ("pdf" . "application/pdf") + ("p7c" . "application/pkcs7-mime") + ("ps" . "application/postscript") + ("ai" . "application/postscript") + ("eps" . "application/postscript") + ("trig" . "application/trig") + ("m3u" . "application/vnd.apple.mpegurl") + ("m3u8" . "application/vnd.apple.mpegurl") + ("xls" . "application/vnd.ms-excel") + ("xlb" . "application/vnd.ms-excel") + ("ppt" . "application/vnd.ms-powerpoint") + ("pot" . "application/vnd.ms-powerpoint") + ("ppa" . "application/vnd.ms-powerpoint") + ("pps" . "application/vnd.ms-powerpoint") + ("pwz" . "application/vnd.ms-powerpoint") + ("wasm" . "application/wasm") + ("bcpio" . "application/x-bcpio") + ("cpio" . "application/x-cpio") + ("csh" . "application/x-csh") + ("dvi" . "application/x-dvi") + ("gtar" . "application/x-gtar") + ("hdf" . "application/x-hdf") + ("h5" . "application/x-hdf5") + ("latex" . "application/x-latex") + ("mif" . "application/x-mif") + ("cdf" . "application/x-netcdf") + ("nc" . "application/x-netcdf") + ("p12" . "application/x-pkcs12") + ("pfx" . "application/x-pkcs12") + ("ram" . "application/x-pn-realaudio") + ("pyc" . "application/x-python-code") + ("pyo" . "application/x-python-code") + ("sh" . "application/x-sh") + ("shar" . "application/x-shar") + ("swf" . "application/x-shockwave-flash") + ("sv4cpio" . "application/x-sv4cpio") + ("sv4crc" . "application/x-sv4crc") + ("tar" . "application/x-tar") + ("tcl" . "application/x-tcl") + ("tex" . "application/x-tex") + ("texi" . "application/x-texinfo") + ("texinfo" . "application/x-texinfo") + ("roff" . "application/x-troff") + ("t" . "application/x-troff") + ("tr" . "application/x-troff") + ("man" . "application/x-troff-man") + ("me" . "application/x-troff-me") + ("ms" . "application/x-troff-ms") + ("ustar" . "application/x-ustar") + ("src" . "application/x-wais-source") + ("xsl" . "application/xml") + ("rdf" . "application/xml") + ("wsdl" . "application/xml") + ("xpdl" . "application/xml") + ("zip" . "application/zip") + ("3gp" . "audio/3gpp") + ("3gpp" . "audio/3gpp") + ("3g2" . "audio/3gpp2") + ("3gpp2" . "audio/3gpp2") + ("aac" . "audio/aac") + ("adts" . "audio/aac") + ("loas" . "audio/aac") + ("ass" . "audio/aac") + ("au" . "audio/basic") + ("snd" . "audio/basic") + ("mp3" . "audio/mpeg") + ("mp2" . "audio/mpeg") + ("opus" . "audio/opus") + ("aif" . "audio/x-aiff") + ("aifc" . "audio/x-aiff") + ("aiff" . "audio/x-aiff") + ("ra" . "audio/x-pn-realaudio") + ("wav" . "audio/x-wav") + ("avif" . "image/avif") + ("bmp" . "image/bmp") + ("gif" . "image/gif") + ("ief" . "image/ief") + ("jpg" . "image/jpeg") + ("jpe" . "image/jpeg") + ("jpeg" . "image/jpeg") + ("heic" . "image/heic") + ("heif" . "image/heif") + ("png" . "image/png") + ("svg" . "image/svg+xml") + ("tiff" . "image/tiff") + ("tif" . "image/tiff") + ("ico" . "image/vnd.microsoft.icon") + ("ras" . "image/x-cmu-raster") + ("pnm" . "image/x-portable-anymap") + ("pbm" . "image/x-portable-bitmap") + ("pgm" . "image/x-portable-graymap") + ("ppm" . "image/x-portable-pixmap") + ("rgb" . "image/x-rgb") + ("xbm" . "image/x-xbitmap") + ("xpm" . "image/x-xpixmap") + ("xwd" . "image/x-xwindowdump") + ("eml" . "message/rfc822") + ("mht" . "message/rfc822") + ("mhtml" . "message/rfc822") + ("nws" . "message/rfc822") + ("css" . "text/css") + ("csv" . "text/csv") + ("html" . "text/html") + ("htm" . "text/html") + ("n3" . "text/n3") + ("txt" . "text/plain") + ("bat" . "text/plain") + ("c" . "text/plain") + ("h" . "text/plain") + ("ksh" . "text/plain") + ("pl" . "text/plain") + ("srt" . "text/plain") + ("rtx" . "text/richtext") + ("tsv" . "text/tab-separated-values") + ("vtt" . "text/vtt") + ("py" . "text/x-python") + ("etx" . "text/x-setext") + ("sgm" . "text/x-sgml") + ("sgml" . "text/x-sgml") + ("vcf" . "text/x-vcard") + ("xml" . "text/xml") + ("mp4" . "video/mp4") + ("mpeg" . "video/mpeg") + ("m1v" . "video/mpeg") + ("mpa" . "video/mpeg") + ("mpe" . "video/mpeg") + ("mpg" . "video/mpeg") + ("mov" . "video/quicktime") + ("qt" . "video/quicktime") + ("webm" . "video/webm") + ("avi" . "video/x-msvideo") + ("movie" . "video/x-sgi-movie"))) diff --git a/neocities/requests.scm b/neocities/requests.scm new file mode 100644 index 0000000..0cb060c --- /dev/null +++ b/neocities/requests.scm @@ -0,0 +1,132 @@ +(define-module (neocities requests) + #:use-module (neocities mime) + #:use-module (json) + #:use-module (ice-9 match) + #:use-module (ice-9 iconv) + #:use-module (ice-9 binary-ports) + #:use-module (gcrypt base64) + #:use-module (gcrypt random) + #:use-module (rnrs base) + #:use-module (rnrs bytevectors) + #:use-module (scheme base) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:export (neocities-url + neocities-request + encode-basic-auth-header + encode-bearer-auth-header + encode-multipart-body)) + +(define* (neocities-url endpoint #:key (querystring '()) + (hostname #f)) + (define (encode-querystring querystring) + (string-join + (map (lambda (x) + (let ((key (car x)) + (value (cdr x))) + (if (list? value) + (string-join + (map (lambda (y) + (string-append (uri-encode key) "[]=" (uri-encode y))) + value) + "&") + (string-append (uri-encode key) "=" (uri-encode value))))) + querystring) + "&")) + + ;; This is for testing locally :) + #;(build-uri 'http #:host "localhost" + #:port 1234 + #:path (string-append "/api/" endpoint) + #:query (encode-querystring querystring)) + (build-uri 'https + #:host (or hostname "neocities.org") + #:path (string-append "/api/" endpoint) + #:query (encode-querystring querystring))) + + +(define (encode-multipart-body files) + "files is an alist with the filename and destination" + + (define (name file) + (car file)) + + (define (destination file) + (cdr file)) + + (define (type file) + (let* ((extension (car (last-pair (string-split (name file) #\.)))) + (type (assoc-ref mime-types extension))) + (if (string? type) + type + (throw 'neocities "Unknown mime-type")))) + + (define (encode-file file) + (bytevector-append + (string->utf8 + (string-append + "Content-Disposition: form-data;" + "filename=\"" (destination file) "\"\r\n" + "Content-Type: " (type file) " \r\n\r\n")) + (call-with-input-file (name file) get-bytevector-all #:binary #t) + (string->utf8 "\r\n"))) + + (define boundary + (string-append "----------------------------------------------------------" + (random-token))) + + (values boundary + (apply bytevector-append + (map (lambda (file i) + (bytevector-append + (string->utf8 (string-append boundary "\r\n")) + (encode-file file) + (if (= (+ i 1) (length files)) + (string->utf8 (string-append "\r\n" boundary "--\r\n\r\n")) + #vu8()))) + files + (iota (length files)))))) + +(define (encode-basic-auth-header username password) + (string-append "Basic " + (base64-encode + (string->utf8 (string-append username ":" password))))) + +(define (encode-bearer-auth-header apikey) + (string-append "Bearer " apikey)) + + +(define* (neocities-request method + url + #:key (body #f) + (auth #f) + (content-type #f)) + + (define (response-error res) + `(("response-code" . ,(response-code res)) + ("response-phrase" . + ,(response-reason-phrase res)) + ("response" . + ,(if (bytevector? body) + (utf8->string body) + body)))) + + (define (response-ok? response) + (> 100 (- (response-code response) 200) -1)) + + (let-values (((response body) + (http-request + url + #:method method + #:body body + #:version '(1 . 1) + #:streaming? #f + #:headers (filter identity + (list + (and content-type `(Content-Type . ,content-type)) + (and auth `(Authorization . ,auth)))) + #:decode-body? #t))) + (if (response-ok? response) + (json-string->scm (utf8->string body)) + (throw 'neocities (response-error response))))) |