Retropikzel
/
foreign-c-libraries
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Bring in the requests library

This commit is contained in:
retropikzel 2026-01-17 14:29:32 +02:00
parent 171971b0dd
commit 8d6e103cdf
5 changed files with 381 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

223
retropikzel/requests.scm Normal file
View File

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

17
retropikzel/requests.sld Normal file
View File

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

84
retropikzel/requests/README.md Normal file
View File

@ -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.

1
retropikzel/requests/VERSION Normal file
View File

@ -0,0 +1 @@
0.10.3

56
retropikzel/requests/test.scm Normal file
View File

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