Skip to content

Commit

Permalink
split the code to private dir
Browse files Browse the repository at this point in the history
  • Loading branch information
yanyingwang committed Feb 25, 2021
1 parent d61d66b commit d7450cd
Show file tree
Hide file tree
Showing 4 changed files with 165 additions and 148 deletions.
160 changes: 12 additions & 148 deletions main.rkt
@@ -1,31 +1,13 @@
#lang at-exp racket/base

(require racket/pretty
racket/string
racket/list
racket/hash
racket/port
racket/match
racket/format
racket/generic
net/http-client
net/uri-codec
net/url-string
json
xml
html-parsing
(for-syntax racket/base racket/list))
(require racket/generic
(for-syntax racket/base racket/list)
(file "./private/params.rkt")
(file "./private/core.rkt"))
(provide (except-out (all-defined-out) define-http-methods) ;; TODO: add contracts to http-get/post...
(all-from-out (file "./private/params.rkt"))
(all-from-out (file "./private/core.rkt")))

(provide (except-out (all-defined-out)
define-http-methods
format-kv
pp-kv)
;; TODO: add contracts to http-get/post...
)

(define current-http-user-agent
(make-parameter @~a{http-client[@(system-type)/@(system-type 'vm)-@(version)]}))
(define current-http-response-auto (make-parameter #t))

;; TODO: enhance below syntax defining code with syntax-case/parse....
(define-syntax (define-http-methods stx)
Expand All @@ -46,7 +28,7 @@
(datum->syntax stx code))
(define-http-methods get head post put delete options patch)

;;;; code Example of (define-http-methods get)
;;;;;;; code Example of (define-http-methods get)
;; (define (http-get url #:data [data (hasheq)]
;; #:path [path ""]
;; #:headers [headers (hasheq)])
Expand All @@ -56,127 +38,9 @@
;; url))
;; (http-do 'get conn #:data data #:path path #:headers headers))

(struct http-connection (url headers data)
#:property prop:procedure
(lambda (self method
#:path [path ""]
#:data [data (hasheq)]
#:headers [headers (hasheq)])
(http-do method self #:data data #:path path #:headers headers))
#:methods gen:custom-write
[(define (write-proc self port mode)
(display @~a{#<http-connection @(~v (http-connection-url self)) @(pp-kv "headers" @(http-connection-headers self)) @(pp-kv "data" @(http-connection-data self))>}
port))])

;; TODO: http-request should be derived from http-connection
(struct http-request (url method headers data)
#:methods gen:custom-write
[(define (write-proc rqt port mode)
(display @~a{#<http-request @(string-upcase (~a (http-request-method rqt))) @(~v (http-request-url rqt)) @(pp-kv "headers" @(http-request-headers rqt)) @(pp-kv "data" @(http-request-data rqt))>} port))])

(struct http-response (request code headers body)
#:methods gen:custom-write
[(define (write-proc self port mode)
(define rqt (http-response-request self))
(define rqt-txt @~a{@(string-upcase (~a (http-request-method rqt))) @(~v (http-request-url rqt))})
(display @~a{#<http-response #<request @|rqt-txt|> @(pp-kv "code" @(http-response-code self)) @(pp-kv "headers" @(http-response-headers self)) @(pp-kv "body" @(http-response-body self))>} port))])

(define (format-kv k v)
(define length (string-length (~a v)))
(define marker @~a{......[@length]})
@~a{@|k|: @(~v @v #:max-width 128 #:limit-marker @marker)})

(pretty-print-depth 1)
(define (pp-kv k v)
@~a{@|k|: @(pretty-format v 'infinity)})
;; (pretty-print-size-hook (lambda (a b c) 1))

(define (http-do method conn
#:data [data1 (hasheq)]
#:path [path ""]
#:headers [headers1 (hasheq)])

(define url (string->url (http-connection-url conn)))
(define data2 (http-connection-data conn))
(define data3 (make-hash (url-query url)))
(define headers2 (http-connection-headers conn))

(define req-path1
(for/list ([e (url-path url)])
(string-append "/" (path/param-path e))))
(define req-path2
(for/list ([e (string-split path "/")])
(string-append "/" e)))
(define req-path1&2 (append req-path1 req-path2))

(define req-host (url-host url))
(define req-path (if (empty? req-path1&2)
"/"
(string-join req-path1&2 "")))

(define req-headers (hash-union headers1 headers2 (hasheq 'User-Agent (current-http-user-agent))
#:combine/key (lambda (k v1 v2) v1)))
(define req-data (hash-union data1 data2 data3
#:combine/key (lambda (k v1 v2) v1)))
(define req (http-request (string-append (url-scheme url)
"://"
req-host
(if (url-port url) (number->string (url-port url)) "")
req-path)
method req-headers req-data))

(define req-headers-raw
(hash-map req-headers
(lambda (k v) (~a k ": " v))))
(define req-data-raw
(match req-headers
;; [(? hash-empty?) ""]
[(hash-table ('Accept "application/json")) (jsexpr->string req-data)]
;; [(hash-table ('Accept "application/x-www-form-urlencoded")) (alist->form-urlencoded (hash->list req-data))]
[_ (alist->form-urlencoded (hash-map req-data
(lambda (k v)
(cons k (if (number? v)
(number->string v)
v)))))]))

(define-values (res-status-raw res-headers-raw res-in)
(http-sendrecv req-host req-path
#:ssl? (match (url-scheme url) ["https" #t] [_ #f])
#:method (string-upcase (symbol->string method))
#:port (match (url-port url)
[(? integer? n) n]
[#f #:when (string=? (url-scheme url) "https")
443]
[_ 80])
#:headers req-headers-raw
#:data req-data-raw))
(define res-body-raw (port->string res-in))

(define res-code
(string->number (second (string-split (bytes->string/utf-8 res-status-raw)))))
(define res-headers
(for/hasheq ([e res-headers-raw])
(match (string-split (bytes->string/utf-8 e) ":")
[(list-rest a b)
(define k (string->symbol a))
(define v (string-trim (string-join b)))
(values k v)])))

(define res-body
(match res-headers
[_ #:when (not (current-http-response-auto))
res-body-raw]
[(hash-table ('Content-Type (regexp #rx"^application/json.*")))
(string->jsexpr res-body-raw)]
[(hash-table ('Content-Type (regexp #rx"^text/html.*")))
(html->xexp res-body-raw)]
[(hash-table ('Content-Type (regexp #rx"^(application/xml|text/xml|application/xhtml+xml).*")))
(string->xexpr res-body-raw)]
[_ res-body-raw]))

(http-response req res-code res-headers res-body))


;;;; =========> test :::
(module+ test
(require rackunit)

Expand All @@ -186,7 +50,7 @@
(http-connection "https://httpbin.org/anything" (hasheq 'Content-Type "application/json" 'Accept "application/json") (hasheq 'made-in "China" 'price 10)))


(check-true (current-http-response-auto))
(check-true (current-http-client/response-auto))

This comment has been minimized.

Copy link
@xandkar

xandkar Mar 16, 2021

Your users would appreciate an API version bump (as per SemVer) for compatibility-breaking changes such as this. I know at least I would :)

This comment has been minimized.

Copy link
@yanyingwang

yanyingwang Mar 16, 2021

Author Owner

@xandkar Really sorry for that. I did not expect there really exist another person using this package except me. I will change the version and add a notice to the doc ASAP.

This comment has been minimized.

Copy link
@xandkar

xandkar Mar 16, 2021

@yanyingwang No worries. It's been a helpful package - thank you for it!

This comment has been minimized.

Copy link
@yanyingwang

yanyingwang Mar 31, 2021

Author Owner

@xandkar Although it seems too late for this, I already added the version tags to GitHub, you can now use raco pkg install "https://github.com/yanyingwang/http-client.git#v0.0.1" for a specific version.

This comment has been minimized.

Copy link
@xandkar

xandkar Apr 16, 2021

@yanyingwang Thanks!


(let* ([res (http-get conn)]
[res-headers (http-response-headers res)]
Expand All @@ -196,8 +60,8 @@
"text/html; charset=utf-8")
(check-true (list? (http-response-body res))))

(parameterize ([current-http-response-auto #f])
(check-false (current-http-response-auto))
(parameterize ([current-http-client/response-auto #f])
(check-false (current-http-client/response-auto))
(define res (http-get conn))
(define res-headers (http-response-headers res))
(define res-body (http-response-body res))
Expand Down
111 changes: 111 additions & 0 deletions private/core.rkt
@@ -0,0 +1,111 @@
#lang at-exp racket/base

(require racket/string racket/list racket/hash racket/port
racket/match racket/format #;racket/pretty
net/http-client net/uri-codec net/url-string
json xml html-parsing
(file "./params.rkt") (file "./utils.rkt"))
(provide (all-defined-out))


(struct http-connection (url headers data)
#:property prop:procedure
(lambda (self method
#:path [path ""]
#:data [data (hasheq)]
#:headers [headers (hasheq)])
(http-do method self #:data data #:path path #:headers headers))
#:methods gen:custom-write
[(define (write-proc self port mode)
(http-client-display @~a{#<http-connection @(~v (http-connection-url self)) @(http-client-pp-kv "headers" @(http-connection-headers self)) @(http-client-pp-kv "data" @(http-connection-data self))>} port))])

;; TODO: http-request should be derived from http-connection
(struct http-request (url method headers data)
#:methods gen:custom-write
[(define (write-proc rqt port mode)
(http-client-display @~a{#<http-request @(string-upcase (~a (http-request-method rqt))) @(~v (http-request-url rqt)) @(http-client-pp-kv "headers" @(http-request-headers rqt)) @(http-client-pp-kv "data" @(http-request-data rqt))>} port)
)])

(struct http-response (request code headers body)
#:methods gen:custom-write
[(define (write-proc self port mode)
(define rqt (http-response-request self))
(define rqt-txt @~a{@(string-upcase (~a (http-request-method rqt))) @(~v (http-request-url rqt))})
(http-client-display @~a{#<http-response #<request @|rqt-txt|> @(http-client-pp-kv "code" @(http-response-code self)) @(http-client-pp-kv "headers" @(http-response-headers self)) @(http-client-pp-kv "body" @(http-response-body self))>} port))])


(define (http-do method conn
#:data [data1 (hasheq)]
#:path [path ""]
#:headers [headers1 (hasheq)])
(define url (string->url (http-connection-url conn)))
(define data2 (http-connection-data conn))
(define data3 (make-hash (url-query url)))
(define headers2 (http-connection-headers conn))
(define req-path1
(for/list ([e (url-path url)])
(string-append "/" (path/param-path e))))
(define req-path2
(for/list ([e (string-split path "/")])
(string-append "/" e)))
(define req-path1&2 (append req-path1 req-path2))
(define req-host (url-host url))
(define req-path (if (empty? req-path1&2)
"/"
(string-join req-path1&2 "")))
(define req-headers (hash-union headers1 headers2 (hasheq 'User-Agent (current-http-client/user-agent))
#:combine/key (lambda (k v1 v2) v1)))
(define req-data (hash-union data1 data2 data3
#:combine/key (lambda (k v1 v2) v1)))
(define req (http-request (string-append (url-scheme url)
"://"
req-host
(if (url-port url) (number->string (url-port url)) "")
req-path)
method req-headers req-data))
(define req-headers-raw
(hash-map req-headers
(lambda (k v) (~a k ": " v))))
(define req-data-raw
(match req-headers
;; [(? hash-empty?) ""]
[(hash-table ('Accept "application/json")) (jsexpr->string req-data)]
;; [(hash-table ('Accept "application/x-www-form-urlencoded")) (alist->form-urlencoded (hash->list req-data))]
[_ (alist->form-urlencoded (hash-map req-data
(lambda (k v)
(cons k (if (number? v)
(number->string v)
v)))))]))
(define-values (res-status-raw res-headers-raw res-in)
(http-sendrecv req-host req-path
#:ssl? (match (url-scheme url) ["https" #t] [_ #f])
#:method (string-upcase (symbol->string method))
#:port (match (url-port url)
[(? integer? n) n]
[#f #:when (string=? (url-scheme url) "https")
443]
[_ 80])
#:headers req-headers-raw
#:data req-data-raw))
(define res-body-raw (port->string res-in))
(define res-code
(string->number (second (string-split (bytes->string/utf-8 res-status-raw)))))
(define res-headers
(for/hasheq ([e res-headers-raw])
(match (string-split (bytes->string/utf-8 e) ":")
[(list-rest a b)
(define k (string->symbol a))
(define v (string-trim (string-join b)))
(values k v)])))
(define res-body
(match res-headers
[_ #:when (not (current-http-client/response-auto))
res-body-raw]
[(hash-table ('Content-Type (regexp #rx"^application/json.*")))
(string->jsexpr res-body-raw)]
[(hash-table ('Content-Type (regexp #rx"^text/html.*")))
(html->xexp res-body-raw)]
[(hash-table ('Content-Type (regexp #rx"^(application/xml|text/xml|application/xhtml+xml).*")))
(string->xexpr res-body-raw)]
[_ res-body-raw]))
(http-response req res-code res-headers res-body))
15 changes: 15 additions & 0 deletions private/params.rkt
@@ -0,0 +1,15 @@
#lang at-exp racket/base


(require racket/format)
(provide (all-defined-out))


(define current-http-client/pretty-print-depth
(make-parameter 1))

(define current-http-client/response-auto
(make-parameter #t))

(define current-http-client/user-agent
(make-parameter @~a{http-client[@(system-type)/@(system-type 'vm)-@(version)]}))
27 changes: 27 additions & 0 deletions private/utils.rkt
@@ -0,0 +1,27 @@
#lang at-exp racket/base

(require debug/repl)
(require racket/pretty
racket/format
(file "./params.rkt"))

(provide (all-defined-out))


(define (http-client-pp-kv k v)
;; @~a{@|k|: @(pretty-format v 'infinity)}
@~a{@|k|: @v})

(define (http-client-display data port)
(parameterize ([pretty-print-depth (current-http-client/pretty-print-depth)])
(pretty-display data port)))


;; (pretty-print-size-hook (lambda (a b c) 1))



;; (define (format-kv k v)
;; (define length (string-length (~a v)))
;; (define marker @~a{......[@length]})
;; @~a{@|k|: @(~v @v #:max-width 128 #:limit-marker @marker)})

0 comments on commit d7450cd

Please sign in to comment.