First commit

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)))))