From 8d6e103cdf0f119094b612ede13d40c48db9b519 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 17 Jan 2026 14:29:32 +0200 Subject: [PATCH] Bring in the requests library --- retropikzel/requests.scm | 223 +++++++++++++++++++++++++++++++++ retropikzel/requests.sld | 17 +++ retropikzel/requests/README.md | 84 +++++++++++++ retropikzel/requests/VERSION | 1 + retropikzel/requests/test.scm | 56 +++++++++ 5 files changed, 381 insertions(+) create mode 100644 retropikzel/requests.scm create mode 100644 retropikzel/requests.sld create mode 100644 retropikzel/requests/README.md create mode 100644 retropikzel/requests/VERSION create mode 100644 retropikzel/requests/test.scm diff --git a/retropikzel/requests.scm b/retropikzel/requests.scm new file mode 100644 index 0000000..f237a61 --- /dev/null +++ b/retropikzel/requests.scm @@ -0,0 +1,223 @@ +(define CURLOPT-POSTFIELDSIZE 60) +(define CURLOPT-POSTFIELDS 10015) +(define CURLOPT-URL 10002) +(define CURLOPT-HTTPHEADER 10023) +(define CURLOPT-WRITEDATA 10001) +(define CURLOPT-CUSTOMREQUEST 10036) +(define CURLOPT-COOKIE 10022) +(define CURLOPT-COOKIEFILE 10031) +(define CURLOPT-COOKIEJAR 10082) +(define CURLINFO-RESPONSE-CODE 2097154) +(define CURLHE-BADINDEX 1) +(define CURLHE-HEADER 1) +(define CURLINFO-COOKIELIST 4194332) +(define randomized? #f) + +(define-c-library libc '("stdlib.h" "stdio.h" "time.h") libc-name '((additional-versions ("6")))) +(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer)) +(define-c-procedure c-fclose libc 'fclose 'int '(pointer)) +(define-c-procedure c-time libc 'time 'int '(pointer)) +(define-c-procedure c-srand libc 'srand 'void '(int)) +(define-c-procedure c-rand libc 'rand 'int '()) + +(define-c-library libcurl '("curl/curl.h") "curl" '((additional-versions ("4" "8")))) +(define-c-procedure curl-easy-init libcurl 'curl_easy_init 'pointer '()) +(define-c-procedure curl-easy-setopt-pointer libcurl 'curl_easy_setopt 'int '(pointer int pointer)) +(define-c-procedure curl-easy-setopt-int libcurl 'curl_easy_setopt 'int '(pointer int int)) +(define-c-procedure curl-slist-append libcurl 'curl_slist_append 'pointer '(pointer pointer)) +(define-c-procedure curl-easy-strerror libcurl 'curl_easy_strerror 'pointer '(int)) +(define-c-procedure curl-easy-perform libcurl 'curl_easy_perform 'int '(pointer)) +(define-c-procedure curl-easy-getinfo libcurl 'curl_easy_getinfo 'int '(pointer int pointer)) +(define-c-procedure curl-easy-nextheader libcurl 'curl_easy_nextheader 'pointer '(pointer int int pointer)) + +(define-record-type response + (make-response bytes + ;cookies + headers + status-code + text + url + download-path) + response? + (bytes response-bytes) + ;(cookies response-cookies) + (headers response-headers) + (status-code response-status-code) + (text response-text) + (url response-url) + (download-path response-download-path)) + +(define (random-to max) + (when (not randomized?) + (c-srand (c-time (make-c-null))) + (set! randomized? #t)) + (modulo (c-rand) max)) + +(define (random-string size) + (letrec + ((looper + (lambda (result integer) + (cond ((= (string-length result) size) result) + ((or (< integer 0) + (> integer 128)) + (looper result (random-to 128))) + (else + (let ((char (integer->char integer))) + (if (not (or (char-alphabetic? char) + (char-numeric? char))) + (looper result (c-rand)) + (looper (string-append result + (string (integer->char integer))) + (random-to 128))))))))) + (looper "" (random-to 128)))) + +(define (random-temp-file) + (string-append (cond-expand (windows (get-environment-variable "TMP")) + (else "/tmp")) + "/scheme-requests-tmp-" + (random-string 6))) + +(define handle-errors + (lambda (result) + (when (not (= result 0)) + (error (c-utf8->string (curl-easy-strerror result)))) + result)) + +(define handle (curl-easy-init)) + +(define (slurp path) + (with-input-from-file + path + (lambda () + (letrec + ((looper (lambda (result text) + (if (eof-object? text) + result + (looper (string-append result text) + (read-string 4000)))))) + (looper "" (read-string 4000)))))) + +(define (slurp-bytes path) + (let ((port (open-binary-input-file path))) + (letrec + ((looper (lambda (result bytes) + (cond ((eof-object? bytes) + (close-port port) + result) + (else + (looper (bytevector-append result bytes) + (read-bytevector 4000 port))))))) + (looper (bytevector) (read-bytevector 4000 port))))) + +(define (get-status-code handle) + (let* ((pointer-size (c-type-size 'long)) + (pointer (make-c-bytevector (c-type-size 'long)))) + (curl-easy-getinfo handle CURLINFO-RESPONSE-CODE pointer) + (let ((code (c-bytevector-ref pointer + 'sint + 0 + (native-endianness) + pointer-size))) + (c-free pointer) + code))) + +(define (set-body handle body) + (curl-easy-setopt-pointer handle CURLOPT-POSTFIELDS (string->c-utf8 body)) + (curl-easy-setopt-int handle CURLOPT-POSTFIELDSIZE (string-length body))) + +(define (set-headers handle headers) + (let ((headers-slist (make-c-null))) + (for-each + (lambda (header) + (set! headers-slist + (curl-slist-append + headers-slist + (string->c-utf8 (string-append (if (symbol? (car header)) + (symbol->string (car header)) + (car header)) + ":" + (if (symbol? (cdr header)) + (symbol->string (cdr header)) + (cdr header))))))) + headers) + (curl-easy-setopt-pointer handle CURLOPT-HTTPHEADER headers-slist))) + +(define (get-headers handle previous-header-struct result) + (let* ((header-struct (curl-easy-nextheader handle + CURLHE-HEADER + 0 + previous-header-struct))) + (if (c-null? header-struct) + result + (let* ((name + (string->symbol + (string-downcase + (c-utf8->string + (c-bytevector-ref header-struct 'pointer 0))))) + (value (c-utf8->string (c-bytevector-ref header-struct + 'pointer + (c-type-size 'pointer))))) + (get-headers handle header-struct (append result + (list (cons name value)))))))) + +(define (copy-string-until str begin-index char) + (let ((result (list))) + (call-with-current-continuation + (lambda (return) + (string-for-each + (lambda (c) + (if (char=? c char) + (return #t) + (set! result (cons c result)))) + (string-copy str begin-index)))) + (list->string (reverse result)))) + +(define (set-cookies handle cookies) + (let ((cookies-string "")) + (for-each + (lambda (header) + (set! cookies-string + (string-append cookies-string + (if (symbol? (car header)) + (symbol->string (car header)) + (car header)) + "=" + (if (symbol? (cdr header)) + (symbol->string (cdr header)) + (cdr header)) + "; "))) + cookies) + (curl-easy-setopt-pointer handle CURLOPT-COOKIE (string->c-utf8 cookies-string)))) + +(define request + (lambda (method url . options) + (let* ((cookies (assoc 'cookies options)) + (headers (assoc 'headers options)) + (body (assoc 'body options)) + (download-path (assoc 'download-path options)) + (tmp-file-path (if download-path + (cdr download-path) + (random-temp-file))) + (tmp-file (c-fopen (string->c-utf8 tmp-file-path) + (string->c-utf8 "w")))) + (curl-easy-setopt-pointer handle + CURLOPT-CUSTOMREQUEST + (string->c-utf8 + (string-upcase (symbol->string method)))) + (curl-easy-setopt-pointer handle CURLOPT-WRITEDATA tmp-file) + (curl-easy-setopt-pointer handle CURLOPT-URL (string->c-utf8 url)) + (when headers (set-headers handle (cdr headers))) + (when cookies (set-cookies handle (cdr cookies))) + (when body (set-body handle (cdr body))) + (handle-errors (curl-easy-perform handle)) + (c-fclose tmp-file) + (let* ((headers (get-headers handle (make-c-null) (list))) + (response (make-response (slurp-bytes tmp-file-path) + ;(get-cookies handle) + headers + (get-status-code handle) + (slurp tmp-file-path) + url + download-path))) + (if (not download-path) (delete-file tmp-file-path)) + response)))) diff --git a/retropikzel/requests.sld b/retropikzel/requests.sld new file mode 100644 index 0000000..6d9834f --- /dev/null +++ b/retropikzel/requests.sld @@ -0,0 +1,17 @@ +(define-library + (retropikzel requests) + (import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (foreign c)) + (export request + response-status-code + response-text + response-bytes + response-headers + ;response-cookies + ) + (include "requests.scm")) + diff --git a/retropikzel/requests/README.md b/retropikzel/requests/README.md new file mode 100644 index 0000000..9acda97 --- /dev/null +++ b/retropikzel/requests/README.md @@ -0,0 +1,84 @@ +# requests + +Scheme library to make https requests. Built with +[foreign c](https://sr.ht/~retropikzel/foreign-c/) and libcurl. + +[Repository](https://git.sr.ht/~retropikzel/foreign-c-requests) + +[Issue tracker](https://sr.ht/~retropikzel/foreign-c/trackers) + +[Jenkins](https://jenkins.scheme.org/job/foreign_c/job/foreign-c-requests/) + + + +## Caveats + +- Not yet working on Mosh +- No cookie reading support yet + + + +## Dependencies + +Depends on libcurl, on Debian/Ubuntu: + + apt-get install libcurl4-openssl-dev + +or + apt-get install libcurl4-gnutls-dev + + +## Documentation + + + +(**request** method url . option ...) + +Method is [http method](https://developer.mozilla.org/en-US/docs/Web/HTTP/Reference/Methods) +as a symbol. For example 'GET or 'POST. + +Url is the url you want to make request to. + +Options are pairs passed in after other arguments, for example: + + (define url "https://snow-fort.org/s/gmail.com/nma.arvydas.silanskas/arvyy/mustache/1.0.2/arvyy-mustache-1.0.2.tgz") + (request 'GET url '(download-path . "/tmp/arvyy-mustache-1.0.2.tgz")) + +Options: + +- download-path + - Downloads the response of request to given path + - If this is not given temporary file is used and deleted after +- headers + - An association list of headers +- body + - Request body as a string + - Example: (define response + (request 'POST + "http://echo-http-requests.appspot.com/echo" + '(body . "Hello world"))) + + + +(**response-status-code** response) + +Returns the HTTP status code of the response. + + + +(**response-text** response) + +Returns the content of the response as text. + + + +(**response-bytes** response) + +Returns the content of the response as bytes. + + + +(**response-headers** response) + +Returns the response headers as an association list. +Header names are downcased symbols. diff --git a/retropikzel/requests/VERSION b/retropikzel/requests/VERSION new file mode 100644 index 0000000..a3f5a8e --- /dev/null +++ b/retropikzel/requests/VERSION @@ -0,0 +1 @@ +0.10.3 diff --git a/retropikzel/requests/test.scm b/retropikzel/requests/test.scm new file mode 100644 index 0000000..6facf11 --- /dev/null +++ b/retropikzel/requests/test.scm @@ -0,0 +1,56 @@ +(import (scheme base) + (scheme write) + (scheme process-context) + (retropikzel requests)) + +(define response (request 'GET + "http://echo-http-requests.appspot.com/echo" + '(headers (foo . bar)) + '(cookies (foo . bar)))) + +(display "Response") +(newline) + +(display "status-code: ") +(write (response-status-code response)) +(newline) + +(display "bytes: ") +(write (response-bytes response)) +(newline) + +(display "text: ") +(write (response-text response)) +(newline) + +(display "headers: ") +(write (response-headers response)) +(newline) + +(when (not (= (response-status-code response) 200)) + (error "Status code not 200" response)) + +(define response1 (request 'POST + "http://echo-http-requests.appspot.com/echo" + '(headers (foo . bar)) + '(cookies (foo . bar)) + '(body . "Hello world"))) + +(display "Response") +(newline) + +(display "status-code: ") +(write (response-status-code response1)) +(newline) + +(display "bytes: ") +(write (response-bytes response1)) +(newline) + +(display "text: ") +(write (response-text response1)) +(newline) + +(display "headers: ") +(write (response-headers response1)) +(newline)