Changeset 860 in project


Ignore:
Timestamp:
06/02/06 23:26:26 (14 years ago)
Author:
felix winkelmann
Message:

cgi for spiffy, svn-client fix, http extension

Files:
11 edited

Legend:

Unmodified
Added
Removed
  • README

    r711 r860  
    131131      code-generation Run-time code generation
    132132      misc        Miscellaneous
     133      macros      Macros and meta-syntax
    133134
    134135  (needs SYMBOL ...)
  • egg-post-commit

    r800 r860  
    172172
    173173(define (put-coop-index-page eggnames repofile)
    174   (http:send-request
    175    (http:make-request
    176     'PUT
    177     (conc +coop-egg-index-page+
    178           "&comment="
    179           (url-encode
    180            (format #f "egg update ~a ~a" (string-trim-right (seconds->string (current-seconds)))
    181                    eggnames) ) )
    182     `(("Authorization" . ,(conc "Basic " (base64:encode (conc "egg-maintainers:" username password))))
    183       ("Content-type" . "text/plain")
    184       ("Connection" . "close") )
    185     (with-output-to-string
    186       (cut pp
    187            `((head "Egg status index")
    188              "\n\nRecently updated eggs: " ,(->string eggnames)
    189              "\n\n"
    190              (html
    191               "<table class='changes' style='width: 60%;' border='0'><tr><th align='left'><b>Release</b></th><th align='left'>Egg</th></td></tr>"
    192               ,@(map (lambda (item f)
    193                        (conc "<tr class=" f "><td class='trdate'>" (car item) "</td><td class='trname'>"
    194                              "<a href='" +call/cc-eggs-url+ "/" (cdr item) ".html'>"
    195                              (cdr item) "</a></td></tr>") )
    196                      (sort (map (match-lambda
    197                                   ((name (attrs ...) . _)
    198                                    (let ((a (assq 'date attrs)))
    199                                      (cons (cadr a) name) ) ) )
    200                                 repofile)
    201                            (lambda (a b) (string>? (car a) (car b))) )
    202                      (circular-list "odd" "even")) )
    203              (html "</table>")
    204              (readonly) ) ) ) ) ) )
     174  (print
     175   (nth-value
     176    0
     177    (http:send-request
     178     (http:make-request
     179      'PUT
     180      (conc +coop-egg-index-page+
     181            "&comment="
     182            (url-encode
     183             (format #f "egg update ~a ~a" (string-trim-right (seconds->string (current-seconds)))
     184                     eggnames) ) )
     185      `(("Authorization" . ,(conc "Basic " (base64:encode (conc "egg-maintainers:" username password))))
     186        ("Content-type" . "text/plain")
     187        ("Connection" . "close") )
     188      (with-output-to-string
     189        (cut pp
     190             `((head "Egg status index")
     191               "\n\nRecently updated eggs: " ,(->string eggnames)
     192               "\n\n"
     193               (html
     194                "<table class='changes' style='width: 60%;' border='0'><tr><th align='left'><b>Release</b></th><th align='left'>Egg</th></td></tr>"
     195                ,@(map (lambda (item f)
     196                         (conc "<tr class=" f "><td class='trdate'>" (car item) "</td><td class='trname'>"
     197                               "<a href='" +call/cc-eggs-url+ "/" (cdr item) ".html'>"
     198                               (cdr item) "</a></td></tr>") )
     199                       (sort (map (match-lambda
     200                                    ((name (attrs ...) . _)
     201                                     (let ((a (assq 'date attrs)))
     202                                       (cons (cadr a) name) ) ) )
     203                                  repofile)
     204                             (lambda (a b) (string>? (car a) (car b))) )
     205                       (circular-list "odd" "even")) )
     206               (html "</table>")
     207               (readonly) ) ) ) ) ) ) ) )
    205208
    206209; Return the directory where the latest release for the egg is to be found,
     
    287290    (with-output-to-file "index.html"
    288291      (cut sxml->xml (make-egg-index-page)) )
    289     (print "Reading current repository file...")
     292    (print "Reading current repository file from " +call/cc-eggs-url+ "/repository ...")
    290293    (match-let ((rf (with-input-from-string (http:GET (conc +call/cc-eggs-url+ "/repository")) read))
    291294                (#(_ m h md mo yr _ _ _ _) (seconds->utc-time (current-seconds))) )
     
    311314        (print "Creating repository file...")
    312315        (with-output-to-file "repository" (cut pp rf2))
    313         (print "Pushing coop index page...")
     316        (print "Pushing coop index page to " +coop-egg-index-page+ " ...")
    314317        (put-coop-index-page eggnames rf2) )  )
    315318    (unless pack-only?
  • http/http-server.scm

    r293 r860  
    5656   http:hard-close-procedure
    5757   http:url-transformation
    58    http:parse-embedded-content
    5958   http:current-request-count
    6059   http:force-close
     
    250249                      (lambda (attrs)
    251250                        (dribble "attributes: ~S" attrs)
    252                         (http:make-request
    253                          (string->canonicalized-symbol method)
    254                          (regex-case url
    255                            ["http://(.+)" (_ url) url]
    256                            [else url] )
    257                          attrs
    258                          (or (and-let* ([ct (find-content-type attrs)])
    259                                ((find-content-parser (string->symbol ct))
    260                                 (let ([a (lookup-request-attribute "content-length" attrs)])
    261                                   (and a (string->number a)) )
    262                                 attrs
    263                                 in) )
    264                              '() )
    265                          p ip) ) ]
     251                        (let-values (((b ub)
     252                                      (let ([ct (find-content-type attrs)])
     253                                        (if ct
     254                                            ((find-content-parser (string->symbol ct))
     255                                             (let ([a (lookup-request-attribute "content-length" attrs)])
     256                                               (and a (string->number a)) )
     257                                             attrs
     258                                             in)
     259                                            (values '() "") ) ) ) )
     260                          (http:make-request
     261                           (string->canonicalized-symbol method)
     262                           (regex-case url
     263                             ["http://(.+)" (_ url) url]
     264                             [else url] )
     265                           attrs
     266                           b ub
     267                           p ip) ) ) ]
    266268                     [else (http:write-bad-request-response out) #f] ) ) ]
    267269            [_ (http:write-bad-request-response out) #f] ) ) ) ) )
    268 
    269 (define (http:parse-embedded-content in)
    270   (let ([port (if (string? in) (open-input-string in) in)])
    271     (let ([attrs (http:read-request-attributes port)])
    272       (cons attrs
    273             (or (and-let* (attrs
    274                            [ct (find-content-type attrs)])
    275                   ((find-content-parser (string->symbol ct))
    276                    (let ([a (lookup-request-attribute "content-length" attrs)])
    277                      (if a
    278                          (fxmin (string->number a) (http:request-limit))
    279                          (http:request-limit)))
    280                    attrs
    281                    port) )
    282                 (read-string #f port) ) ) ) ) )
    283270
    284271(define (find-content-type attrs)
     
    294281(define (find-content-parser type)
    295282  (or (http:content-parser type)
    296       (lambda (size _ port) (read-string size port)) ) )
     283      (lambda (size _ port)
     284        (let ((s (read-string size port)))
     285          (values s s) ) ) ) )
    297286
    298287(define (lookup-request-attribute a attrs)
     
    418407 'application/x-www-form-urlencoded
    419408 (lambda (size _ port)
    420    (let ([data (string-split (read-string size port) "&")])
    421      (map (lambda (def)
    422             (regex-case def
    423               ["([^=]+)=(.*)" (_ name value)
    424                (cons name (http:canonicalize-string value)) ]
    425               [else (cons def #f)] ) )
    426           data) ) ) )
    427 
    428 (define read-multipart/form-data
    429   (let ([rx (regexp "boundary=([^ ;\n\r\t]+)")])
    430     (lambda (size attrs port)
    431       (let ([raw (read-string size port)])
    432         ;;(fprintf (current-error-port) "raw: ~S~%" raw)
    433         (match (string-search rx (alist-ref "content-type" attrs string-ci=?))
    434           [(_ b)
    435            (let ([brx (regexp (conc "--" b "(--)?\r\n"))])
    436              (let loop ([cs '()] [i 0])
    437                (match (string-search-positions brx raw i)
    438                  [((start end) _)
    439                   (loop (if (zero? i) cs (cons (substring raw i start) cs))
    440                         end) ]
    441                  [_ (reverse (map http:parse-embedded-content cs))] ) ) ) ]
    442           [_ raw] ) ) ) ) )
    443 
    444 (http:content-parser 'multipart/form-data read-multipart/form-data)
     409   (let* ([raw (read-string size port)]
     410          [data (string-split raw "&")])
     411     (values
     412      (map (lambda (def)
     413             (regex-case def
     414               ["([^=]+)=(.*)" (_ name value)
     415                (cons name (http:canonicalize-string value)) ]
     416               [else (cons def #f)] ) )
     417           data)
     418      raw) ) ) )
  • http/http-utils.scm

    r354 r860  
    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!) )
     45   http:request-sslctx http:request-sslctx-set! http:request-unparsed-body http:request-unparsed-body-set!) )
    4646
    4747(declare (uses srfi-1 srfi-13 srfi-18 regex))
     
    7070  url                                   ; string
    7171  protocol                              ; symbol
    72   body                                  ; string | #f
     72  body                                  ; string | #f (possibly identical to unparsed body)
     73  unparsed-body                         ; string
    7374  completion                            ; procedure | #f
    7475  sslctx)                               ; <ssl-client-context|symbol> | 'sslv2-or-v3
     
    7778  (let ([make-http:request make-http:request])
    7879    (lambda (method url . more)
    79       (let-optionals more ([attrs '()] [body '()] [protocol 'HTTP/1.0] [ip "<unknown>"])
    80         (make-http:request method attrs ip url protocol body #f 'sslv2-or-v3) ) ) ) )
     80      (let-optionals more ([attrs '()] [body '()] [unpbody ""] [protocol 'HTTP/1.0] [ip "<unknown>"])
     81        (make-http:request method attrs ip url protocol body unpbody #f 'sslv2-or-v3) ) ) ) )
    8182
    8283(define http:read-request-attributes
  • http/http.html

    r628 r860  
    1717<h3>Version:</h3>
    1818<ul>
     19<li>1.47
     20Removed multipart support, added unparsed request body field, content-parsers return additional
     21raw body
    1922<li>1.46
    2023Bugfix in url-parser
     
    226229is parsed by a so-called <i>content-parser</i>, which is a procedure that reads the request-body
    227230from the port given by <code>(current-input-port)</code>. Content-types are encoded as symbols.
    228 Special parsers for the <code>application/x-www-form-urlencoded</code> and
    229 <code>multipart/form-data</code> are
    230 predefined, other content-parsers have to be defined by application-code using the procedure
     231A parser for <code>application/x-www-form-urlencoded</code>
     232is predefined, other content-parsers have to be defined by application-code using the procedure
    231233<code>http:content-parser</code>, or the default parser will be invoked (which reads the content
    232234as a plain string).
    233235<br>The content-parser for text returns the request-body as a string. The content-parser for urlencoded
    234236data returns the request-body as an a-list that maps variables to strings.
    235 The content-parser for multipart data returns an a-list, where each pair holds another
    236 a-list with the embedded MIME headers and their values in the car and the actual
    237 body (parsed with the appropriate content-parser) in the cdr.
    238237
    239238<p><dl>
     
    251250
    252251<dt><pre><b>[procedure] (http:content-parser CONTENTTYPE [PROC])</b></pre>
    253 <dd>Reads or sets the parser-procedure (a procedure of three arguments: the size of the content
     252<dd>Returns or sets the parser-procedure (a procedure of three arguments: the size of the content
    254253(may be <code>#f</code>), the a-list of request headers and an input port) for <code>CONTENTTYPE</code>, which should be a symbol.
     254The content-parser procedure should return two values: the parsed and the unparsed (raw) request body.
    255255
    256256<dt><pre><b>[procedure] (http:write-response-header [CODE MSG [ALIST [PORT [PROTOCOL]]]])</b></pre>
  • http/http.setup

    r628 r860  
    1212 'http
    1313 '("http-client.so" "http-server.so" "http-utils.so" "http.html")
    14  '((version 1.46)
     14 '((version 1.47)
    1515   (documentation "http.html") ) )
  • spiffy/spiffy-base.scm

    r855 r860  
    5959
    6060(define spiffy-version 2)
    61 (define spiffy-release 32)
     61(define spiffy-release 33)
    6262
    6363(define spiffy-tcp-port 8080)
     
    349349          (and (string-match spiffy-cgi-pattern name)
    350350               (file-exists? fn)
    351                (file-execute-access? fn)
    352351               fn) ]
    353352         [_ #f] ) ) )
     
    605604         (m (string-match "([^?]+)\\?(.*)" p))
    606605         (as (http:request-attributes r))
     606         (body (http:request-unparsed-body r))
    607607         (env (append
    608608               `(,(conc "SERVER_PROTOCOL=" (http:request-protocol r))
     
    612612                 ,(conc "CONTENT_TYPE="
    613613                        (or (and-let* ((a (assoc "content-type" as))) (cdr a))
    614                             "text/plain") )
     614                            "application/octet-stream") )
    615615                 ,(conc "CONTENT_LENGTH="
    616616                        (or (and-let* ((a (assoc "content-length" as))) (cdr a))
    617                             "0") )
     617                            (string-length body) ) )
    618618                 ,(conc "SCRIPT_NAME=" (if m (cadr m) fn))
    619                  ,(conc "QUERY_STRING=" (if m (caddr m) "")) )
     619                 ,(conc "REMOTE_ADDR=" (http:request-ip r))
     620                 ,@(if m (list (conc "QUERY_STRING=" (caddr m))) '()) )
    620621               (map (lambda (attr)
    621622                      (string-append
     
    627628                    as)
    628629               spiffy-cgi-default-environment)) )
    629     (let-values (((i o pid) (process fn (list (http:request-url r)) env)))
    630       (spiffy-debug "(cgi) started program ~a ..." fn)
    631       (display (http:request-body r) o)
    632       (close-output-port o)
    633       (let loop ()
    634         (let ((ln (read-line i)))
    635           (cond ((eof-object? ln)
    636                  (spiffy-debug "(cgi) premature termination of cgi program")
    637                  (http:write-error-response 500 "Internal server error") )
    638                 ((string=? "" ln)
    639                  (when (and (eq? 'HTTP/1.1 (http:request-protocol r))
    640                             (and-let* ([a (assoc "connection" (http:request-attributes r))])
    641                               (string-ci=? "keep-alive" (cdr a)) ) )
    642                    (display "Connection: Keep-alive\r\n") )
    643                  (let* ((body (read-string #f i))
    644                         (len (string-length body)) )
    645                    (close-input-port i)
    646                    (spiffy-debug "(cgi) program terminated normally, response has ~a bytes" len)
    647                    (printf "Content-Length: ~A\r\n\r\n" len)
    648                    (unless (eq? 'HEAD (http:request-method (current-request)))
    649                      (display body) ) ) )
    650                 (else
    651                  (printf "~a\r\n" ln)
    652                  (loop) ) ) ) ) ) ) )
     630    (if (file-execute-access? fn)
     631        (let-values (((i o pid) (process fn (list (http:request-url r)) env)))
     632          (spiffy-debug "(cgi) started program ~a ..." fn)
     633          (display body o)
     634          (close-output-port o)
     635          (let loop ()
     636            (let ((ln (read-line i)))
     637              (cond ((eof-object? ln)
     638                     (spiffy-debug "(cgi) premature termination of cgi program")
     639                     (http:write-error-response 500 "Internal server error") )
     640                    ((string=? "" ln)
     641                     (when (and (eq? 'HTTP/1.1 (http:request-protocol r))
     642                                (and-let* ([a (assoc "connection" (http:request-attributes r))])
     643                                  (string-ci=? "keep-alive" (cdr a)) ) )
     644                       (display "Connection: Keep-alive\r\n") )
     645                     (let* ((body (read-string #f i))
     646                            (len (string-length body)) )
     647                       (close-input-port i)
     648                       (spiffy-debug "(cgi) program terminated normally, response has ~a bytes" len)
     649                       (printf "Content-Length: ~A\r\n\r\n" len)
     650                       (unless (eq? 'HEAD (http:request-method (current-request)))
     651                         (display body) ) ) )
     652                    (else
     653                     (printf "~a\r\n" ln)
     654                     (loop) ) ) ) ) )
     655        (http:write-error-response 500 "Internal server error") ) ) )
    653656
    654657(define (include-ssp fn)
  • spiffy/spiffy.html

    r852 r860  
    4848<h3>Version:</h3>
    4949<ul>
     50<li>2.33
     51More complete CGI support (needs <a href="http.html">http</a> 1.47)
    5052<li>2.32
    5153Preliminary CGI support
     
    166168<p><i>Spiffy</i> is a simple web-server for the <a href="http://www.call-with-current-continuation.org/chicken.html">
    167169Chicken</a> Scheme system. It's quite easy to set up and use and it can be customized in numerous ways.
    168 <br>Note that only very basic functionality is provided, there is no support for CGI scripts or encoding styles.
     170<br>Note that only very basic functionality is provided, there is no support for encoding styles.
    169171
    170172<dl>
     
    341343using global variables.
    342344
    343 <p>Spiffy supports a subset of the CGI/1.1 spec.
     345<p>Spiffy supports a subset of the CGI/1.1 spec. All request headers will be passed as environment variables
     346to the CGI program (which must be executable and match <code>spiffy-cgi-pattern</code>), prefixed with <code>HTTP_</code>,
     347and converted to uppercase, with hyphens (<code>"-"</code>) replaced by an underscore (<code>"_"</code>).
     348The CGI program will receiver the request body in unparsed form from stdin and should write a complete
     349HTTP response to stdout.
    344350
    345351</ul>
  • spiffy/spiffy.setup

    r853 r860  
    55 '("spiffy-base.so" "spiffy.scm" "spiffy.html")
    66 '((syntax)
    7    (version 2.32)
     7   (version 2.33)
    88   (documentation "spiffy.html")
    99   (require-at-runtime spiffy-base)))
  • svn-client/trunk/svn-client.html

    r747 r860  
    125125<h3>Version</h3>
    126126<ul>
     127<li>0.2 Adds <code>-lsvn_subr-1</code> when linking on Mac OS X [felix]
    127128<li>0.1 Initial release</li></ul></div>
    128129<div class="section">
  • svn-client/trunk/svn-client.setup

    r594 r860  
    1 (run (csc -s -O2 -d0 svn-client.scm "-C`apr-config --includes || apr-1-config --includes`" -L "\"`apr-config --libs --link-ld 2>/dev/null || apr-1-config --libs --link-ld`\"" -L -lsvn_client-1 -C -I/usr/include/subversion-1 -C -I/usr/local/include/subversion-1))
     1(run (csc -s -O2 -d0 svn-client.scm
     2          "-C`apr-config --includes || apr-1-config --includes`" -L "\"`apr-config --libs --link-ld 2>/dev/null || apr-1-config --libs --link-ld`\""
     3          -lsvn_client-1
     4          ,(if (eq? (software-version) 'macosx) "-lsvn_subr-1" "")
     5          -C -I/usr/include/subversion-1 -C -I/usr/local/include/subversion-1))
    26
    37(install-extension 'svn-client '("svn-client.so"))
Note: See TracChangeset for help on using the changeset viewer.