summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--README.md3
-rw-r--r--neocities.scm4
-rw-r--r--neocities/api.scm98
-rw-r--r--neocities/mime.scm153
-rw-r--r--neocities/requests.scm132
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)))))