Changeset 8443 in project


Ignore:
Timestamp:
02/13/08 13:00:56 (12 years ago)
Author:
elf
Message:

redid the client post method. changed compilation order. added three new
utility functions for requests (add attribute, get attrib, remove attrib).
bumped version.

Location:
release/3/http/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/3/http/trunk/http-client.scm

    r8431 r8443  
    302302  (url-encode arg (list #\_ #\- #\* #\. #\@)))
    303303
    304 (define (http:POST req #!optional (args '()) (delim1 "") (delim2 "") (encoder values))
    305   (let* ([req (cond ((http:request? req)
    306                      req)
    307                     ((string? req)
    308                      (http:make-request
    309                       'POST req '(("Connection" . "close") ("Content-Type" . "application/x-www-form-urlencoded"))))
    310                     (else
    311                      (error "http:POST" "unknown http request" req)))]
    312          [ctype (alist-ref "content-type" (http:request-attributes req) string-ci=?)])
    313     (cond ((equal? ctype "application/x-www-form-urlencoded")
    314            (set! delim1 "=")
    315            (set! delim2 "&")
    316            (set! encoder http:form-url-encode))
    317           ;...
    318           )
    319     (http:request-body-set!
    320      req
    321      (string-intersperse
    322       (map (lambda (x) (if (pair? x)
    323                            (string-append (encoder (car x)) delim1 (encoder (cdr x)))
    324                            x))
    325            args)
    326       delim2))
    327     (let-values ([(header a i o) (http:send-request req)])
    328       (if a (http:extract-cookies req a))
    329       (http:read-body a i))))
    330 
     304(define (http:POST req #!optional (args '())
     305                       #!key (type      "application/x-www-form-urlencoded")
     306                             (headers   '())
     307                             (delim     ""))
     308    (let ((req   (cond ((http:request? req)
     309                           req)
     310                       ((string? req)
     311                           (http:make-request 'POST req headers))
     312                       (else
     313                           (error 'http:POST "unknown http request" req))))
     314          (typ   #f))
     315        (or (http:request-attribute-get req "Connection")
     316            (http:request-attribute-add! req "Connection" "close"))
     317        (or (http:request-attribute-get req "Content-Type")
     318            (http:request-attribute-add! req "Content-Type" type))
     319        (set! typ (http:request-attribute-get req "Content-Type"))
     320        (cond ((or (not (string? typ)) (string-null? typ))
     321                  (error 'http:POST "invalid Content-Type header" typ))
     322              ((not (list? args))
     323                  (if (string? args)
     324                      (http:request-body-set! req args)
     325                      (error 'http:POST "invalid body args")))
     326              ((string-ci=? "application/x-www-form-urlencoded" typ)
     327                  (http:request-body-set! req
     328                      (string-intersperse
     329                          (map
     330                              (lambda (x)
     331                                  (if (pair? x)
     332                                      (string-append
     333                                          (http:form-url-encode (car x))
     334                                          "="
     335                                          (http:form-url-encode (cdr x)))
     336                                      x))
     337                              args)
     338                          "&")))
     339              ((string-ci=? "multipart/form-data" typ)
     340                  (if (string-null? delim)
     341                      (set! delim "----chicken-scheme---\r\n")
     342                      (set! delim (conc "---" delim "\r\n")))
     343                  (http:request-attribute-add! req "Content-Type"
     344                      (string-append typ "; boundary=" delim))
     345                  (http:request-body-set! req
     346                      (string-append (fold-right
     347                          (lambda (e r)
     348                              (conc
     349                                  "--" delim
     350                                  "Content-disposition: form-data; name=\""
     351                                  (if (pair? e) (car e) e) "\""
     352                                  (cond ((not (pair? e))
     353                                            (conc "\r\n\r\n"))
     354                                        ((and (list? e) (pair? (cadr e)))
     355                                            (fold-right
     356                                                (lambda (a n)
     357                                                    (if (pair? a)
     358                                                        (if (string-suffix?
     359                                                                ":" (car a))
     360                                                            (conc "\r\n"
     361                                                                  (car a) " "
     362                                                                  (cdr a) n)
     363                                                            (conc "; "
     364                                                                  (car a) "=\""
     365                                                                  (cdr a) "\""
     366                                                                  n))
     367                                                        (conc "\r\n\r\n" a n)))
     368                                                ""
     369                                                (cdr e)))
     370                                        (else
     371                                            "\r\n\r\n" (cdr e)))
     372                                  "\r\n" r))
     373                          ""
     374                          args)
     375                        "--" delim "--")))
     376              (else
     377                  (http:request-body-set! req
     378                      (string-intersperse args delim))))
     379        (call-with-values
     380            (lambda ()
     381                (http:send-request req))
     382            (lambda (hdr a i o)
     383                (and a
     384                     (http:extract-cookies req a))
     385                (http:read-body a i)))))
     386
  • release/3/http/trunk/http-server.scm

    r8442 r8443  
    384384
    385385(define (get/post-handler req)
    386   (dribble "raw request value: ~S" req)
     386  (apply dribble "request values: method = ~S  attributes = ~S  ip = ~S  url = ~S  protocol = ~S  body = ~S  unparsed-body = ~S  completion = ~S  sslctx = ~S" (map (lambda (p) (p req)) (list http:request-method http:request-attributes http:request-ip http:request-url http:request-protocol http:request-body http:request-unparsed-body http:request-completion http:request-sslctx)))
    387387  (let-values (((loc get-args) (http:decode-url (http:request-url req))))
    388388    (let ([args (append
  • release/3/http/trunk/http-utils.scm

    r6847 r8443  
    4343   http:request-url-set! http:request-protocol-set! http:request-attributes-set! http:request-body-set! http:request-method-set!
    4444   http:request-ip http:request-ip-set! http:request-completion http:request-completion-set!
    45    http:request-sslctx http:request-sslctx-set! http:request-unparsed-body http:request-unparsed-body-set!) )
     45   http:request-sslctx http:request-sslctx-set! http:request-unparsed-body http:request-unparsed-body-set!
     46   http:request-attribute-get http:request-attribute-add!
     47   http:request-attribute-del!
     48   ) )
    4649
    4750(declare (uses srfi-1 srfi-13 srfi-18 regex))
     
    102105                     [else #f] ) ] ) ) ) ) ) ) )
    103106
     107(define (http:request-attribute-get req attr #!optional (default #f))
     108    (or (http:request? req)
     109        (error 'http:request-attribute-get "not a http:request object" req))
     110    (or (and (string? attr) (not (string-null? attr)))
     111        (error 'http:request-attribute-get "not a valid string" attr))
     112    (let ((r   (alist-ref attr (http:request-attributes req) string-ci=?)))
     113        (if r
     114            r
     115            default)))
     116
     117(define (http:request-attribute-add! req attr val)
     118    (or (http:request? req)
     119        (error 'http:request-attribute-add! "not a http:request object" req))
     120    (or (and (string? attr) (not (string-null? attr)))
     121        (error 'http:request-attribute-add! "not a valid string" attr))
     122    (let ((r   (assoc attr (http:request-attributes req) string-ci=?)))
     123        (if r
     124            (set-cdr! r (->string val))
     125            (http:request-attributes-set! req
     126                (append (http:request-attributes req)
     127                        (list (cons attr (->string val))))))
     128        req))
     129
     130(define (http:request-attribute-del! req attr)
     131    (or (http:request? req)
     132        (error 'http:request-attribute-del! "not a http:request object" req))
     133    (or (and (string? attr) (not (string-null? attr)))
     134        (error 'http:request-attribute-del! "not a valid string" attr))
     135    (http:request-attributes-set! req
     136        (fold-right
     137            (lambda (e r)
     138                (if (string-ci=? attr (car e))
     139                    r
     140                    (cons e r)))
     141            '()
     142            (http:request-attributes req)))
     143    req)
     144
    104145
    105146;;; URL and string operations:
  • release/3/http/trunk/http.setup

    r7155 r8443  
    66      "") )
    77
    8 (make (("http-client.so" ("http-client.scm")
     8(make (("http-utils.so" ("http-utils.scm")
     9        (run (csc -s -O2 -d1
     10               ,@(if has-exports? '(-check-imports -emit-exports http-utils.exports) '())
     11               http-utils.scm)))
     12       ("http-client.so" ("http-client.scm")
    913        (run (csc -s -O2 -d1
    1014              ,@(if has-exports? '(-check-imports -emit-exports http-client.exports) '())
     
    1317        (run (csc -s -O2 -d1
    1418              ,@(if has-exports? '(-check-imports -emit-exports http-server.exports) '())
    15               http-server.scm)))
    16        ("http-utils.so" ("http-utils.scm")
    17         (run (csc -s -O2 -d1
    18                ,@(if has-exports? '(-check-imports -emit-exports http-utils.exports) '())
    19                http-utils.scm))) )
    20   '("http-client.so" "http-server.so" "http-utils.so") )
     19              http-server.scm))) )
     20  '("http-utils.so" "http-client.so" "http-server.so") )
    2121
    2222(install-extension
    2323 'http
    2424 '()
    25  '((version 2.1) ) )
     25 '((version 2.2) ) )
     26
     27(install-extension
     28 'http-utils
     29 '("http-utils.so")
     30 `((version 2.2)
     31         ,@(if has-exports? `((exports "http-utils.exports")) '()) ) )
    2632
    2733(install-extension
    2834 'http-client
    2935 '("http-client.so")
    30  `((version 2.1)
     36 `((version 2.2)
    3137         ,@(if has-exports? `((exports "http-client.exports")) '()) ) )
    3238
     
    3440 'http-server
    3541 '("http-server.so")
    36  `((version 2.1)
     42 `((version 2.2)
    3743         ,@(if has-exports? `((exports "http-server.exports")) '()) ) )
    3844
    39 (install-extension
    40  'http-utils
    41  '("http-utils.so")
    42  `((version 2.1)
    43          ,@(if has-exports? `((exports "http-utils.exports")) '()) ) )
Note: See TracChangeset for help on using the changeset viewer.