A simple http client in Racket by p4bl0

http-client.rkt

#lang racket/base

;; By http://www.reddit.com/user/p4bl0 at http://paste.fulltxt.net/FZ4-HeULc

;; `racket -il readline -t http-client.rkt`
;; then you can use (M "/path/...") where M can be get, post, put, delete.
;; When authenticated, you can logout using (logout).
;; The host and port can be changed using set!.

(require racket/tcp
         racket/port
         racket/string
         racket/list
         net/base64
         net/uri-codec)

(provide (all-defined-out))

(define host "localhost")
(define port 8080)
(define name #f)
(define pass #f)

(define (logout)
  (set! pass #f))

(define (make-auth-header)
  (if (and name pass)
      (string-append
       "Authorization: Basic "
       (bytes->string/utf-8
        (base64-encode
         (string->bytes/utf-8
          (string-append name ":" pass)))))
      ""))

(define (parse-header header)
  (let ((header (regexp-split ": " header)))
    (cons (string->symbol (string-downcase (car header)))
          (let ((v (string-join (cdr header) ": ")))
            (if (string=? "" v)
                v
                (substring v 0 (sub1 (string-length v))))))))

(define (read-headers in)
  (let loop ()
    (let ((header (read-line in)))
      (if (or (eof-object? header) (string=? header "\r"))
          null
          (list* (parse-header header) (loop))))))

(define (request method path [body ""])
  (with-handlers
      ((exn:fail:network?
        (lambda (e)
          (display ";; Error: ")
          (displayln (exn-message e)))))
    (let-values (((in out) (tcp-connect host port)))
      (file-stream-buffer-mode out 'line)
      (display
       (string-append (symbol->string method) " " path " HTTP/1.1\n"
                      "Host: " host "\n"
                      (make-auth-header)
                      "Content-length: "
                      (number->string (string-length body))
                      "\n\n"
                      (if (string=? "" body)
                          ""
                          (string-append body "\n\n")))
       out)
      (close-output-port out)
      (displayln ";; Request sent.")
      (let ((evt (read-line-evt in)))
        (let ((status (sync evt))
              (headers (read-headers in)))
          (let ((code (string->number (substring status 9 12))))
            (case code
              ((401)
               (let* ((auth-hdr (assoc 'www-authenticate headers))
                      (realm (substring (cdr auth-hdr)
                                        12 (string-length (cdr auth-hdr)))))
                 (display ";; Authentication required: ")
                 (displayln realm)
                 (display "; Username: ")
                 (set! name (read-line))
                 (unless (string=? "" name)
                   (display "; Password: ")
                   (set! pass (read-line))
                   (request method path body))))
              ((303)
               (let* ((url (assoc 'location headers))
                      (path (cadr (regexp-split
                                   (string-append
                                    host ":" (number->string port))
                                   (cdr url)))))
                 (display ";; Redirection: ")
                 (displayln (cdr url))
                 (display "; Follow? [y/N]: ")
                 (let ((f (read-line)))
                   (when (string=? "y" f)
                     (request 'GET path)))))
              (else
               (display ";; Response (")
               (display (number->string code))
               (displayln "):")
               (let loop ()
                 (let ((s (read-line in)))
                   (unless (eof-object? s)
                     (displayln s)
                     (loop))))
               (displayln ";; End of response.")))
            (close-input-port in)))))))

(define (make-body)
  (let ((b (let loop ((body ""))
             (display "; Add binding: ")
             (let ((arg-name (read-line)))
               (if (string=? "" arg-name)
                   body
                   (begin
                     (display "; Value: ")
                     (let ((arg-value (read-line)))
                       (loop
                        (string-append
                         body
                         (string-append arg-name "="
                                        (uri-encode arg-value) "&"))))))))))
    (substring b 0 (sub1 (string-length b)))))

(define (get path)
  (read-line)
  (request 'GET path))

(define (post path)
  (read-line)
  (request 'POST path (make-body)))

(define (put path)
  (read-line)
  (request 'PUT path (make-body)))

(define (delete path)
  (read-line)
  (request 'DELETE path))