107 lines
3.7 KiB
Scheme
107 lines
3.7 KiB
Scheme
(define line-end "\r\n")
|
|
(define (recv-all socket)
|
|
(letrec*
|
|
((buffer-size 4000)
|
|
(looper (lambda (bytes result)
|
|
(if (< (bytevector-length bytes) 4000)
|
|
(bytevector-append bytes result)
|
|
(looper (socket-recv socket 4000)
|
|
(bytevector-append result bytes))))))
|
|
(looper (socket-recv socket 4000) (make-bytevector 0))))
|
|
|
|
(define (read-string-until-eof port)
|
|
(letrec*
|
|
((looper (lambda (str result)
|
|
(if (eof-object? str)
|
|
result
|
|
(looper (read-string 4000 port)
|
|
(string-append result str))))))
|
|
(looper (read-string 4000 port) "")))
|
|
|
|
(define (string-trim-left str)
|
|
(letrec*
|
|
((beyond-whitespace #f)
|
|
(looper (lambda (result rest)
|
|
(if (null? rest)
|
|
(list->string (reverse result))
|
|
(if (and (not beyond-whitespace)
|
|
(char-whitespace? (car rest)))
|
|
(looper result (cdr rest))
|
|
(begin
|
|
(set! beyond-whitespace #t)
|
|
(looper (cons (car rest) result) (cdr rest))))))))
|
|
(looper '() (string->list str))))
|
|
|
|
(define (string->status str)
|
|
`((http-version ,(string-copy str 0 8))
|
|
(status-code ,(string-copy str 9 12))
|
|
(status-message ,(string-copy str 13))))
|
|
|
|
(define (string->headers str)
|
|
(let ((first-punctuation-index 0)
|
|
(index -1))
|
|
(string-for-each
|
|
(lambda (c)
|
|
(set! index (+ index 1))
|
|
(when (and (= first-punctuation-index 0)
|
|
(char=? c #\:))
|
|
(set! first-punctuation-index index)))
|
|
str)
|
|
(list (string-copy str 0 first-punctuation-index)
|
|
(string-copy str (+ first-punctuation-index 1)))))
|
|
|
|
(define (read-headers port)
|
|
(letrec*
|
|
((looper
|
|
(lambda (line result)
|
|
(if (string=? line "")
|
|
result
|
|
(looper (read-line port)
|
|
(append result
|
|
(list (map string-trim-left (string->headers line)))))))))
|
|
`(headers ,(looper (read-line port) '()))))
|
|
|
|
(define (string->http-response str)
|
|
(cond ((not (string? str))
|
|
(error "string->http-reseponse: Argument must be string" str))
|
|
((and (>= (string-length str) 8)
|
|
(string=? (string-copy str 0 8) "HTTP/1.1"))
|
|
(display "HERE: str ")
|
|
(write str)
|
|
(newline)
|
|
(let* ((port (open-input-string str))
|
|
(status (string->status (read-line port)))
|
|
(headers (read-headers port))
|
|
(body (read-string-until-eof port)))
|
|
(append `(,@status ,headers (body ,body)))
|
|
))
|
|
(else (error "string->http-response: unsupported HTTP response" str))))
|
|
|
|
(define (http-request url . options)
|
|
(let* ((uri (string->uri url))
|
|
(host (uri-host uri))
|
|
(port (cond ((equal? (uri-scheme uri) 'http) (or (uri-port uri) "80"))
|
|
((equal? (uri-scheme uri) 'https) (or (uri-port uri) "443"))
|
|
(else (error "http-request: Unknown url scheme" url))))
|
|
(method (cadr (or (assq 'method options) '(#f "GET"))))
|
|
(path (or (uri-path uri) "/"))
|
|
(socket (make-client-socket host port))
|
|
(request
|
|
(string-append
|
|
method " " path " HTTP/1.1" line-end
|
|
"Host: test" line-end
|
|
"Accept: text/html" line-end
|
|
line-end))
|
|
(response
|
|
(begin
|
|
(socket-send socket (string->utf8 request))
|
|
(string->http-response (utf8->string (recv-all socket))))))
|
|
(display "HERE: ")
|
|
(write port)
|
|
(newline)
|
|
(display "HERE: ")
|
|
(write (uri-scheme uri))
|
|
(newline)
|
|
response
|
|
))
|