Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

use blocking io by default in snow

Browse source
This commit is contained in:
Alex Shinn 2015-06-22 20:51:20 +09:00
parent fdc2558a76
commit 64f3be9c99
4 changed files with 40 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
lib/chibi/net.scm
View file

@ -29,7 +29,7 @@
;;> values on success - the socket, an input port, and an ;;> values on success - the socket, an input port, and an
;;> output port - or \scheme{#f} on failure. ;;> output port - or \scheme{#f} on failure.
(define (open-net-io host service) (define (open-net-io host service . o)
(let lp ((addr (get-address-info host service))) (let lp ((addr (get-address-info host service)))
(if (not addr) (if (not addr)
(error "couldn't find address" host service) (error "couldn't find address" host service)
@ -46,7 +46,11 @@
(lp (address-info-next addr))) (lp (address-info-next addr)))
(else (else
(cond-expand (cond-expand
(threads (set-file-descriptor-status! sock open/non-block)) (threads
(if (not (and (pair? o) (car o)))
(let ((st (bitwise-and (get-file-descriptor-status sock)
open/non-block)))
(set-file-descriptor-status! sock st))))
(else #f)) (else #f))
(list sock (list sock
(open-input-file-descriptor sock #t) (open-input-file-descriptor sock #t)

2
lib/chibi/net.sld
View file

@ -21,6 +21,6 @@
get-peer-name get-peer-name
;; C structs ;; C structs
sockaddr addrinfo) sockaddr addrinfo)
(import (chibi) (chibi filesystem)) (import (chibi) (chibi filesystem) (srfi 33))
(include-shared "net") (include-shared "net")
(include "net.scm")) (include "net.scm"))

9
lib/chibi/net/http.scm
View file

@ -165,7 +165,8 @@
(let* ((io (open-net-io (let* ((io (open-net-io
host host
(or (uri-port uri) (or (uri-port uri)
(if (eq? 'https (uri-scheme uri)) 443 80)))) (if (eq? 'https (uri-scheme uri)) 443 80))
(assq-ref in-headers 'blocking)))
(in (cadr io)) (in (cadr io))
(out (car (cddr io)))) (out (car (cddr io))))
(display method out) (display method out)
@ -180,8 +181,10 @@
(display "\r\n" out))) (display "\r\n" out)))
(for-each (for-each
(lambda (x) (lambda (x)
(display (car x) out) (display ": " out) (cond
(display (cdr x) out) (display "\r\n" out)) ((not (eq? 'blocking (car x)))
(display (car x) out) (display ": " out)
(display (cdr x) out) (display "\r\n" out))))
in-headers) in-headers)
(display "Connection: close\r\n\r\n" out) (display "Connection: close\r\n\r\n" out)
(http-send-body in-headers body out) (http-send-body in-headers body out)

50
lib/chibi/snow/commands.scm
View file

@ -766,29 +766,33 @@
;; a subset of http-post functionality that can shell out to curl ;; a subset of http-post functionality that can shell out to curl
;; depending on config ;; depending on config
(define (snow-post cfg uri params) (define (snow-post cfg uri params)
(if (conf-get cfg 'use-curl?) (cond
(let ((cmd `(curl --silent ((conf-get cfg 'use-curl?)
,@(append-map (let ((cmd `(curl --silent
(lambda (x) ,@(append-map
(cond (lambda (x)
((and (pair? (cdr x)) (assq 'value (cdr x))) (cond
=> (lambda (y) ((and (pair? (cdr x)) (assq 'value (cdr x)))
`("-F" ,(string-append => (lambda (y)
(display-to-string (car x)) "=" `("-F" ,(string-append
(display-to-string (cdr y)))))) (display-to-string (car x)) "="
((and (pair? (cdr x)) (assq 'file (cdr x))) (display-to-string (cdr y))))))
=> (lambda (y) ((and (pair? (cdr x)) (assq 'file (cdr x)))
`("-F" ,(string-append => (lambda (y)
(display-to-string (car x)) "=@" `("-F" ,(string-append
(display-to-string (cdr y)))))) (display-to-string (car x)) "=@"
(else (display-to-string (cdr y))))))
`("-F" ,(string-append (else
(display-to-string (car x)) "=" `("-F" ,(string-append
(display-to-string (cdr x))))))) (display-to-string (car x)) "="
params) (display-to-string (cdr x)))))))
,(uri->string uri)))) params)
(open-input-bytevector (process->bytevector cmd))) ,(uri->string uri))))
(http-post uri params))) (open-input-bytevector (process->bytevector cmd))))
((not (conf-get cfg 'non-blocking-io))
(http-post uri params '((blocking . #t))))
(else
(http-post uri params))))
(define (remote-command cfg name path params) (define (remote-command cfg name path params)
(let ((uri (remote-uri cfg name path))) (let ((uri (remote-uri cfg name path)))