78 lines
3.4 KiB
Scheme
78 lines
3.4 KiB
Scheme
(define CURLOPT-POSTFIELDSIZE 60)
|
|
(define CURLOPT-POSTFIELDS 10015)
|
|
(define CURLOPT-URL 10002)
|
|
(define CURLOPT-HTTPHEADER 10023)
|
|
(define CURLOPT-WRITEDATA 10001)
|
|
(define CURLOPT-WRITEFUNCTION 20011)
|
|
(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") #f '())
|
|
(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
|
|
(define-c-procedure c-fclose libc 'fclose 'int '(pointer))
|
|
(define-c-procedure c-perror libc 'perror 'void '(pointer))
|
|
|
|
(define-c-library libcurl '("curl/curl.h") "curl" '((additional-versions ("4"))))
|
|
(define-c-procedure curl-easy-init libcurl 'curl_easy_init 'pointer '())
|
|
(define-c-procedure curl-easy-cleanup libcurl 'curl_easy_cleanup 'void '(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 (get-right-char-until str chars)
|
|
(let ((result '())
|
|
(until? #f))
|
|
(for-each
|
|
(lambda (c)
|
|
(when (member c chars) (set! until? #t))
|
|
(when (not until?) (set! result (cons c result))))
|
|
(reverse (string->list str)))
|
|
(list->string result)))
|
|
|
|
(define (download-file url . download-path)
|
|
(when (not (string? url))
|
|
(error "download-file error: url must be string" url))
|
|
(when (and (not (null? download-path))
|
|
(not (string? (car download-path))))
|
|
(error "download-file error: download-path must be string"
|
|
(car download-path)))
|
|
(let* ((handle (curl-easy-init))
|
|
(to-path (if (null? download-path)
|
|
(get-right-char-until url '(#\/ #\\))
|
|
(car download-path)))
|
|
(to-path-cbv (string->c-bytevector to-path))
|
|
(file-mode-cbv (string->c-bytevector "w"))
|
|
(to-file-cbv (c-fopen to-path-cbv file-mode-cbv))
|
|
(url-cbv (string->c-bytevector url)))
|
|
(display "HERE: to-path ")
|
|
(write to-path)
|
|
(newline)
|
|
(when (c-bytevector-null? to-file-cbv)
|
|
(let* ((error-message "download-file error")
|
|
(error-pointer (string->c-bytevector error-message)))
|
|
(c-perror error-pointer)
|
|
(c-bytevector-free file-mode-cbv to-path-cbv to-file-cbv url-cbv error-pointer)
|
|
(error error-message)))
|
|
(curl-easy-setopt-pointer handle CURLOPT-WRITEDATA to-file-cbv)
|
|
(curl-easy-setopt-pointer handle CURLOPT-URL url-cbv)
|
|
(let ((result (curl-easy-perform handle)))
|
|
(when (not (= result 0))
|
|
(let* ((error-cbv (curl-easy-strerror result))
|
|
(error-string (c-bytevector->string error-cbv)))
|
|
(c-bytevector-free error-cbv)
|
|
(error error-string url)))
|
|
(curl-easy-cleanup handle)
|
|
;(c-bytevector-free file-mode-cbv to-path-cbv to-file-cbv url-cbv)
|
|
)))
|