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
;;> 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)))
(if (not addr)
(error "couldn't find address" host service)
@ -46,7 +46,11 @@
(lp (address-info-next addr)))
(else
(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))
(list sock
(open-input-file-descriptor sock #t)

2
lib/chibi/net.sld
View file

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

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

@ -165,7 +165,8 @@
(let* ((io (open-net-io
host
(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))
(out (car (cddr io))))
(display method out)
@ -180,8 +181,10 @@
(display "\r\n" out)))
(for-each
(lambda (x)
(display (car x) out) (display ": " out)
(display (cdr x) out) (display "\r\n" out))
(cond
((not (eq? 'blocking (car x)))
(display (car x) out) (display ": " out)
(display (cdr x) out) (display "\r\n" out))))
in-headers)
(display "Connection: close\r\n\r\n" 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
;; depending on config
(define (snow-post cfg uri params)
(if (conf-get cfg 'use-curl?)
(let ((cmd `(curl --silent
,@(append-map
(lambda (x)
(cond
((and (pair? (cdr x)) (assq 'value (cdr x)))
=> (lambda (y)
`("-F" ,(string-append
(display-to-string (car x)) "="
(display-to-string (cdr y))))))
((and (pair? (cdr x)) (assq 'file (cdr x)))
=> (lambda (y)
`("-F" ,(string-append
(display-to-string (car x)) "=@"
(display-to-string (cdr y))))))
(else
`("-F" ,(string-append
(display-to-string (car x)) "="
(display-to-string (cdr x)))))))
params)
,(uri->string uri))))
(open-input-bytevector (process->bytevector cmd)))
(http-post uri params)))
(cond
((conf-get cfg 'use-curl?)
(let ((cmd `(curl --silent
,@(append-map
(lambda (x)
(cond
((and (pair? (cdr x)) (assq 'value (cdr x)))
=> (lambda (y)
`("-F" ,(string-append
(display-to-string (car x)) "="
(display-to-string (cdr y))))))
((and (pair? (cdr x)) (assq 'file (cdr x)))
=> (lambda (y)
`("-F" ,(string-append
(display-to-string (car x)) "=@"
(display-to-string (cdr y))))))
(else
`("-F" ,(string-append
(display-to-string (car x)) "="
(display-to-string (cdr x)))))))
params)
,(uri->string uri))))
(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)
(let ((uri (remote-uri cfg name path)))