220 lines
8.7 KiB
Scheme
220 lines
8.7 KiB
Scheme
(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 'int 0)))
|
|
(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))))
|