Changeset 29360 in project


Ignore:
Timestamp:
07/15/13 14:04:41 (7 years ago)
Author:
Ivan Raikov
Message:

cgi: first approximation of MIME parsing

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

Legend:

Unmodified
Added
Removed
  • release/4/cgi/trunk/environment.scm

    r29259 r29360  
    4545                      ))
    4646
    47         (require-library extras abnf abnf-consumers)
    48         (import (prefix abnf abnf:)
    49                 (prefix abnf-consumers abnf:) )
     47        (require-library abnf)
    5048        (import (only abnf <CoreABNF> CharLex->CoreABNF))
    5149
    52         (require-extension cgi-grammar)
     50        (require-library cgi-grammar)
     51        (import (only cgi-grammar <CGI> CoreABNF->CGI))
     52       
    5353
    5454        ;; helper macro for mutually-recursive parser definitions
     
    7070          (CharLex->CoreABNF char-list-<CharLex>))
    7171       
    72         (import-instance (<CoreABNF> char-list-<CoreABNF> abnf.) )
    73        
    74 
     72        (define char-list-<CGI> (CoreABNF->CGI char-list-<CoreABNF>))
     73       
     74        (import-instance (<CGI> char-list-<CGI> p.) )
    7575
    7676        ;; CGI Variable Definitions
     
    107107          (meta-variable
    108108           (AUTH_TYPE)
    109            p-auth-type
     109           p.auth-type
    110110           (lambda (x) (let ((v (car x))) (and (not (string-null? v)) (string->symbol v))))
    111111           ))
     
    114114          (meta-variable
    115115           (CONTENT_LENGTH)
    116            p-content-length
     116           p.content-length
    117117           (lambda (x) (let ((v (car x)))
    118118                           (and (not (string-null? v)) (string->number v))))
     
    122122          (meta-variable
    123123           (CONTENT_TYPE)
    124            p-content-type
     124           p.content-type
    125125           reverse
    126126           ))
     
    129129          (meta-variable
    130130           (GATEWAY_INTERFACE)
    131            p-gateway-interface
     131           p.gateway-interface
    132132           ))
    133133       
     
    135135          (meta-variable
    136136           (PATH_INFO)
    137            p-path-info
     137           p.path-info
    138138           (lambda (x) (let ((v (car x))) (or (and (string-null? v) (list)) v)))
    139139           ))
     
    146146            (and s (meta-variable
    147147                    (string->list s)
    148                     p-query-string
     148                    p.query-string
    149149                    ))
    150150            ))
     
    153153          (meta-variable
    154154           (REMOTE_ADDR)
    155            p-remote-addr
     155           p.remote-addr
    156156           ))
    157157       
     
    159159          (meta-variable
    160160           (REMOTE_HOST)
    161            p-remote-host
     161           p.remote-host
    162162           (lambda (x) (let ((v (car x))) (or (and (string-null? v) (list)) v)))
    163163           ))
     
    172172          (let ((m (REQUEST_METHOD)))
    173173            (and m (meta-variable
    174                     m p-request-method
     174                    m p.request-method
    175175                    car
    176176                    ))
     
    180180          (meta-variable
    181181           (SCRIPT_NAME)
    182              p-path-info
     182             p.path-info
    183183             (lambda (x) (let ((v (car x))) (or (and (string-null? v) (list)) v)))
    184184             ))
     
    187187          (meta-variable
    188188           (SERVER_NAME)
    189            p-server-name
     189           p.server-name
    190190           ))
    191191       
     
    193193          (meta-variable
    194194           (SERVER_PORT)
    195            p-server-port
     195           p.server-port
    196196           (lambda (x) (let ((v (car x))) (and (not (string-null? v)) (string->number v))))
    197197           ))
     
    200200          (meta-variable
    201201           (SERVER_PROTOCOL)
    202            p-server-protocol
     202           p.server-protocol
    203203           (lambda (x) (and (not (null? x)) (cons (string->symbol (car x)) (cdr x))))
    204204           ))
     
    207207          (meta-variable
    208208           (SERVER_SOFTWARE)
    209            p-server-software
     209           p.server-software
    210210           ))
    211211
  • release/4/cgi/trunk/grammar.scm

    r29259 r29360  
    1313
    1414        (
    15 
     15         <CGI> CoreABNF->CGI
    1616          )
    1717
     
    2727                      ))
    2828
    29         (require-library extras abnf abnf-consumers)
    30         (import (prefix abnf abnf:)
    31                 (prefix abnf-consumers abnf:) )
    32         (import (only abnf <CoreABNF> CharLex->CoreABNF))
    33 
     29        (require-library abnf abnf-consumers)
     30        (import (prefix abnf abnf:) (prefix abnf-consumers abnf:))
     31        (import (only abnf <CoreABNF>))
    3432
    3533        ;; helper macro for mutually-recursive parser definitions
     
    3937
    4038
    41           ;; Match any US-ASCII character except for control characters and
    42           ;; separators.
    43 
    44           (define token  (abnf:repetition1
    45                           (abnf.set (char-set-difference
    46                                      char-set:ascii
    47                                      (char-set-union char-set:iso-control
    48                                                      (char-set #\space #\tab)
    49                                                      (string->char-set "()<>@,;:\\/[]?={}"))))))
     39        (define-class <CGI>  (<CoreABNF> A)
     40          auth-type
     41          content-length
     42          content-type
     43          gateway-interface
     44          path-info
     45          query-string
     46          remote-addr
     47          remote-host
     48          request-method
     49          server-name
     50          server-port
     51          server-protocol
     52          server-software
     53          part-headers
     54          )
     55
     56        ;; Match any US-ASCII character except for control characters and
     57        ;; separators.
     58       
     59        (define=> (token (<CoreABNF> abnf.))
     60          (abnf:repetition1
     61           (abnf.set (char-set-difference
     62                      char-set:ascii
     63                      (char-set-union char-set:iso-control
     64                                      (char-set #\space #\tab)
     65                                      (string->char-set "()<>@,;:\\/[]?={}"))))))
    5066
    5167
     
    5470          ;; without blackslash-quoting except double-quote and the backslash
    5571          ;; itself.
    56           (define qdtext          (abnf.set
    57                                    (char-set-difference
    58                                     char-set:printing
    59                                     (char-set #\" #\\))))
    60 
    61           (define quoted-string    (abnf:concatenation
    62                                     (abnf:drop-consumed abnf.dquote)
    63                                     (abnf:repetition qdtext)
    64                                     (abnf:drop-consumed abnf.dquote)))
    65 
    66 
    67           (define p-auth-type
    68             (abnf:bind-consumed->string
    69              (abnf:alternatives
    70               (abnf.lit "Basic")
    71               (abnf.lit "Digest")
    72               token)))
    73 
    74 
    75           (define p-content-length
     72          (define=> (qdtext (<CoreABNF> abnf.))
     73            (abnf.set
     74             (char-set-difference
     75              char-set:printing
     76              (char-set #\" #\\))))
     77
     78          (define=> (quoted-string (<CoreABNF> abnf.))
     79            (abnf:concatenation
     80             (abnf:drop-consumed abnf.dquote)
     81             (abnf:repetition qdtext)
     82             (abnf:drop-consumed abnf.dquote)))
     83
     84
     85          (define=> (auth-type (<CoreABNF> abnf.))
     86            (lambda (token)
     87              (abnf:bind-consumed->string
     88               (abnf:alternatives
     89                (abnf.lit "Basic")
     90                (abnf.lit "Digest")
     91                token))
     92              ))
     93
     94
     95          (define=> (content-length (<CoreABNF> abnf.))
    7696            (abnf:bind-consumed->string
    7797             (abnf:repetition1 abnf.decimal)))
    7898
    7999
    80           (define p-gateway-interface
     100          ;;       CONTENT_TYPE = "" | media-type
     101          ;;       media-type   = type "/" subtype *( ";" parameter )
     102          ;;       type         = token
     103          ;;       subtype      = token
     104          ;;       parameter    = attribute "=" value
     105          ;;       attribute    = token
     106          ;;       value        = token | quoted-string
     107         
     108          (define=> (content-type  (<CoreABNF> abnf.))
     109            (lambda (token quoted-string)
     110              (let* ((type       (abnf:bind-consumed->string token))
     111                     (subtype    (abnf:bind-consumed->string token))
     112                     (attribute  (abnf:bind-consumed->string token))
     113                     (value      (abnf:bind-consumed->string
     114                                  (abnf:alternatives token quoted-string)))
     115                     (parameter  (abnf:bind-consumed-strings->list
     116                                  (abnf:concatenation
     117                                   attribute
     118                                   (abnf:drop-consumed (abnf.char #\=))
     119                                   value)))
     120                     (media-type (abnf:concatenation
     121                                  (abnf:bind-consumed-strings->list 'type type)
     122                                  (abnf:drop-consumed (abnf.char #\/))
     123                                  (abnf:bind-consumed-strings->list 'subtype subtype)
     124                                  (abnf:repetition
     125                                   (abnf:concatenation
     126                                    (abnf:drop-consumed
     127                                     (abnf:concatenation
     128                                      (abnf.char #\;)
     129                                      (abnf:repetition
     130                                       (abnf.set (char-set #\space #\tab)))
     131                                      ))
     132                                    parameter))))
     133                     )
     134               
     135                (abnf:alternatives
     136                 media-type
     137                 abnf:pass)
     138               
     139                ))
     140            )
     141
     142
     143          (define=> (gateway-interface (<CoreABNF> abnf.))
    81144            (abnf:concatenation
    82145             (abnf:bind-consumed->symbol (abnf.lit "CGI"))
     
    93156          ;;       lchar     = <any TEXT or CTL except "/">
    94157
    95           (define lchar          (abnf.set
    96                                   (char-set-difference
    97                                    (char-set-union char-set:printing char-set:iso-control)
    98                                    (char-set #\\))))
    99 
    100           (define lsegment       (abnf:bind-consumed->string (abnf:repetition lchar)))
    101           (define path           (abnf:concatenation
    102                                   lsegment
    103                                   (abnf:repetition
    104                                    (abnf:concatenation
    105                                     (abnf:drop-consumed (abnf.char #\/))
    106                                     lsegment))))
     158          (define=> (lchar (<CoreABNF> abnf.))
     159            (abnf.set
     160             (char-set-difference
     161              (char-set-union char-set:printing char-set:iso-control)
     162              (char-set #\\))))
     163
     164
     165          (define (lsegment lchar)
     166            (abnf:bind-consumed->string (abnf:repetition lchar)))
     167
     168
     169          (define=> (path (<CoreABNF> abnf.))
     170            (lambda (lsegment)
     171              (abnf:concatenation
     172               lsegment
     173               (abnf:repetition
     174                (abnf:concatenation
     175                 (abnf:drop-consumed (abnf.char #\/))
     176                 lsegment)))))
     177
    107178         
    108           (define p-path-info
    109             (abnf:alternatives
    110              (abnf:concatenation (abnf:drop-consumed (abnf.char #\/))
    111                                  (abnf:consumed-pairs->list path))
    112              abnf:pass))
     179          (define=> (path-info (<CoreABNF> abnf.))
     180            (lambda (path)
     181              (abnf:alternatives
     182               (abnf:concatenation (abnf:drop-consumed (abnf.char #\/))
     183                                   (abnf:consumed-pairs->list path))
     184               abnf:pass)
     185              ))
    113186
    114187
     
    118191          ;;       uric         = reserved | unreserved | escaped
    119192
    120           (define escaped    (abnf:concatenation
    121                               (abnf.char #\%)
    122                               abnf.hexadecimal
    123                               abnf.hexadecimal))
    124           (define reserved   (abnf.set-from-string ";/?:@&=+$,[]"))
    125           (define mark       (abnf.set-from-string "-_.!~*'()"))
    126           (define unreserved (abnf:alternatives abnf.alpha abnf.decimal mark))
    127 
    128           (define uric (abnf:alternatives reserved unreserved escaped))
    129 
    130           (define p-query-string  (abnf:repetition uric))
     193          (define=> (escaped (<CoreABNF> abnf.))
     194            (abnf:concatenation
     195             (abnf.char #\%)
     196             abnf.hexadecimal
     197             abnf.hexadecimal))
     198
     199
     200          (define=> (reserved (<CoreABNF> abnf.))   
     201            (abnf.set-from-string ";/?:@&=+$,[]"))
     202
     203
     204          (define=> (mark (<CoreABNF> abnf.))     
     205            (abnf.set-from-string "-_.!~*'()"))
     206
     207
     208          (define=> (unreserved (<CoreABNF> abnf.))
     209            (lambda (mark)
     210              (abnf:alternatives abnf.alpha abnf.decimal mark)))
     211
     212
     213          (define (uric reserved unreserved escaped)
     214            (abnf:alternatives reserved unreserved escaped))
     215
     216
     217          (define (query-string uric)
     218            (abnf:repetition uric))
    131219
    132220          ;;       REMOTE_ADDR  = hostnumber
     
    137225          ;;       hexseq       = 1*4hex *( ":" 1*4hex )
    138226
    139           (define ddot           (abnf:drop-consumed (abnf.char #\.)))
    140           (define dcolon         (abnf:drop-consumed (abnf.char #\:)))
    141           (define ipv4d          (abnf:bind-consumed->string (abnf:variable-repetition 1 3 abnf.decimal)))
    142           (define ipv4-address   (abnf:concatenation ipv4d ddot ipv4d ddot ipv4d ddot ipv4d))
    143           (define ipv6h          (abnf:bind-consumed->string
    144                                   (abnf:variable-repetition 1 4 abnf.hexadecimal)))
    145           (define hexseq         (abnf:concatenation
    146                                   ipv6h
    147                                   (abnf:repetition
    148                                    (abnf:concatenation dcolon ipv6h))))
    149           (define hexpart        (abnf:alternatives
    150                                   hexseq
    151                                   (abnf:concatenation
    152                                    (abnf:optional-sequence hexseq)
    153                                    (abnf.lit "::")
    154                                    (abnf:optional-sequence hexseq)
    155                                    )))
    156           (define ipv6-address (abnf:concatenation
    157                                 hexpart
    158                                 (abnf:optional-sequence
    159                                  (abnf:concatenation dcolon ipv4-address))))
    160 
    161           (define hostnumber (abnf:alternatives ipv4-address ipv6-address))
    162 
    163           (define p-remote-addr hostnumber)
     227          (define=> (ddot (<CoreABNF> abnf.))
     228            (abnf:drop-consumed (abnf.char #\.)))
     229
     230
     231          (define=> (dcolon (<CoreABNF> abnf.))
     232            (abnf:drop-consumed (abnf.char #\:)))
     233
     234
     235          (define=> (ipv4d (<CoreABNF> abnf.))
     236            (abnf:bind-consumed->string (abnf:variable-repetition 1 3 abnf.decimal)))
     237
     238
     239          (define (ipv4-address ipv4d ddot)
     240            (abnf:concatenation ipv4d ddot ipv4d ddot ipv4d ddot ipv4d))
     241
     242
     243          (define=> (ipv6h (<CoreABNF> abnf.))
     244            (abnf:bind-consumed->string
     245             (abnf:variable-repetition 1 4 abnf.hexadecimal)))
     246
     247
     248          (define (hexseq ipv6h dcolon)         
     249            (abnf:concatenation
     250             ipv6h
     251             (abnf:repetition
     252              (abnf:concatenation dcolon ipv6h))))
     253
     254
     255          (define=> (hexpart (<CoreABNF> abnf.))
     256            (lambda (hexseq)
     257              (abnf:alternatives
     258               hexseq
     259               (abnf:concatenation
     260                (abnf:optional-sequence hexseq)
     261                (abnf.lit "::")
     262                (abnf:optional-sequence hexseq)
     263                ))
     264              ))
     265
     266
     267          (define (ipv6-address ipv4-address hexpart dcolon)
     268            (abnf:concatenation
     269             hexpart
     270             (abnf:optional-sequence
     271              (abnf:concatenation dcolon ipv4-address))))
     272
     273
     274          (define (hostnumber ipv4-address ipv6-address)
     275            (abnf:alternatives ipv4-address ipv6-address))
     276
     277
     278          (define remote-addr hostnumber)
    164279
    165280          ;;       REMOTE_HOST   = "" | hostname | hostnumber
     
    169284          ;;       alphahypdigit = alphanum | "-"
    170285
    171           (define alphanum      (abnf:alternatives
    172                                  abnf.alpha
    173                                  abnf.decimal))
    174 
    175           (define alphahypdigit (abnf:alternatives
    176                                  alphanum
    177                                  abnf.char #\-))
    178 
    179           (define toplabel     (abnf:bind-consumed->string
    180                                 (abnf:concatenation
    181                                  abnf.alpha
    182                                  (abnf:optional-sequence
    183                                   (abnf:concatenation
    184                                    (abnf:repetition alphahypdigit)
    185                                    alphanum)))))
    186 
    187           (define domainlabel  (abnf:bind-consumed->string
    188                                 (abnf:concatenation
    189                                  alphanum
    190                                  (abnf:optional-sequence
    191                                   (abnf:concatenation
    192                                    (abnf:repetition alphahypdigit)
    193                                    alphanum)))))
    194 
    195           (define hostname    (abnf:concatenation
    196                                (abnf:repetition
    197                                 (abnf:concatenation
    198                                  domainlabel
    199                                  ddot))
    200                                toplabel
    201                                (abnf:optional-sequence
    202                                 ddot)))
    203 
    204           (define p-remote-host  (abnf:alternatives
    205                                   hostname hostnumber
    206                                   abnf:pass))
     286          (define=> (alphanum (<CoreABNF> abnf.))
     287            (abnf:alternatives
     288             abnf.alpha
     289             abnf.decimal))
     290
     291
     292          (define=> (alphahypdigit (<CoreABNF> abnf.))
     293            (abnf:alternatives
     294             alphanum
     295             abnf.char #\-))
     296
     297
     298          (define=> (toplabel (<CoreABNF> abnf.))
     299            (lambda (alphahypdigit alphanum)
     300              (abnf:bind-consumed->string
     301               (abnf:concatenation
     302                abnf.alpha
     303                (abnf:optional-sequence
     304                 (abnf:concatenation
     305                  (abnf:repetition alphahypdigit)
     306                  alphanum))))
     307              ))
     308
     309
     310          (define (domainlabel alphahypdigit alphanum)
     311            (abnf:bind-consumed->string
     312             (abnf:concatenation
     313              alphanum
     314              (abnf:optional-sequence
     315               (abnf:concatenation
     316                (abnf:repetition alphahypdigit)
     317                alphanum)))
     318             ))
     319
     320
     321          (define (hostname domainlabel toplabel ddot)
     322            (abnf:concatenation
     323             (abnf:repetition
     324              (abnf:concatenation
     325               domainlabel
     326               ddot))
     327             toplabel
     328             (abnf:optional-sequence
     329              ddot)))
     330
     331         
     332          (define (remote-host hostname hostnumber)
     333            (abnf:alternatives
     334             hostname hostnumber
     335             abnf:pass))
    207336
    208337
     
    211340          ;;       extension-method = "PUT" | "DELETE" | token
    212341
    213           (define extension-method  (abnf:alternatives
    214                                      (abnf.lit "PUT")
    215                                      (abnf.lit "DELETE")
    216                                      token))
    217 
    218           (define method (abnf:alternatives
    219                           (abnf.lit "GET")
    220                           (abnf.lit "POST")
    221                           (abnf.lit "HEAD")
    222                           extension-method))
    223 
    224           (define p-request-method (abnf:bind-consumed->string method))
     342          (define=> (extension-method (<CoreABNF> abnf.))
     343            (lambda (token)
     344              (abnf:alternatives
     345               (abnf.lit "PUT")
     346               (abnf.lit "DELETE")
     347               token)))
     348
     349
     350          (define=> (method (<CoreABNF> abnf.))
     351            (lambda (extension-method)
     352              (abnf:alternatives
     353               (abnf.lit "GET")
     354               (abnf.lit "POST")
     355               (abnf.lit "HEAD")
     356               extension-method)))
     357
     358         
     359          (define (request-method method) (abnf:bind-consumed->string method))
    225360
    226361         
     
    228363          ;;      server-name = hostname | ipv4-address | ( "[" ipv6-address "]" )
    229364
    230           (define p-server-name
    231             (abnf:alternatives
    232              hostname
    233              ipv4-address
    234              (abnf:drop-consumed (abnf.char #\[))
    235              ipv6-address
    236              (abnf:drop-consumed (abnf.char #\]))))
     365          (define=>  (server-name (<CoreABNF> abnf.))
     366            (lambda (ipv4-address ipv6-address)
     367              (abnf:alternatives
     368               hostname
     369               ipv4-address
     370               (abnf:drop-consumed (abnf.char #\[))
     371               ipv6-address
     372               (abnf:drop-consumed (abnf.char #\])))
     373              ))
    237374
    238375
     
    240377          ;;       server-port = 1*digit
    241378
    242           (define p-server-port
     379          (define=> (server-port (<CoreABNF> abnf.))
    243380            (abnf:bind-consumed->string
    244381             (abnf:repetition abnf.decimal)))
     
    252389          (define protocol token)
    253390
    254           (define extension-version
    255             (abnf:concatenation
    256              (abnf:bind-consumed->string protocol )
    257              (abnf:optional-sequence
    258               (abnf:concatenation
    259                (abnf:drop-consumed (abnf.char #\/))
    260                (abnf:bind-consumed->string (abnf:repetition1 abnf.decimal))
    261                ddot
    262                (abnf:bind-consumed->string (abnf:repetition1 abnf.decimal))))))
    263 
    264           (define HTTP-Version
     391          (define=> (extension-version  (<CoreABNF> abnf.))
     392            (lambda (protocol ddot)
     393              (abnf:concatenation
     394               (abnf:bind-consumed->string protocol )
     395               (abnf:optional-sequence
     396                (abnf:concatenation
     397                 (abnf:drop-consumed (abnf.char #\/))
     398                 (abnf:bind-consumed->string (abnf:repetition1 abnf.decimal))
     399                 ddot
     400                 (abnf:bind-consumed->string (abnf:repetition1 abnf.decimal)))))))
     401
     402
     403          (define=> (HTTP-Version  (<CoreABNF> abnf.))
    265404            (abnf:concatenation
    266405             (abnf:bind-consumed->string (abnf.lit "HTTP"))
     
    270409               (abnf:bind-consumed->string (abnf:repetition1 abnf.decimal))
    271410               ddot
    272                (abnf:bind-consumed->string (abnf:repetition1 abnf.decimal))))))
     411               (abnf:bind-consumed->string (abnf:repetition1 abnf.decimal))
     412               ))
     413             ))
    273414
    274415         
    275           (define p-server-protocol   
    276             (abnf:bind-consumed-strings->list
    277              (abnf:alternatives
    278               HTTP-Version
    279               (abnf.lit "INCLUDED")
    280               extension-version)))
    281 
    282 
    283           (define product
    284             (abnf:concatenation
    285              token
    286              (abnf:optional-sequence
     416          (define=> (server-protocol (<CoreABNF> abnf.))
     417            (lambda (HTTP-Version extension-version)
     418              (abnf:bind-consumed-strings->list
     419               (abnf:alternatives
     420                HTTP-Version
     421                (abnf.lit "INCLUDED")
     422                extension-version))
     423              ))
     424
     425
     426          (define=> (product  (<CoreABNF> abnf.))
     427            (lambda (token)
    287428              (abnf:concatenation
    288                (abnf.char #\/)
    289                token))))
    290 
    291           (define ctext
     429               token
     430               (abnf:optional-sequence
     431                (abnf:concatenation
     432                 (abnf.char #\/)
     433                 token))
     434               )))
     435
     436
     437          (define=> (ctext (<CoreABNF> abnf.))
    292438            (abnf.set (char-set-difference char-set:graphic (char-set #\( #\) #\\))))
    293439
    294           (define comment
     440
     441          (define=> (comment (<CoreABNF> abnf.))
    295442            (vac
    296443             (abnf:concatenation
    297444              (abnf.char #\()
    298445              (abnf:repetition (abnf:alternatives ctext comment))
    299               (abnf.char #\)))))
     446              (abnf.char #\)))
     447             ))
     448
     449
     450          (define consumed-objects-lift-any
     451            (abnf:consumed-objects-lift
     452             (abnf:consumed-objects identity)))
     453
     454          (define=> (header  (<CoreABNF> abnf.))
     455            (lambda (ss p)
     456              (abnf:bind (consumed-objects-lift-any)
     457                         (abnf:concatenation
     458                          (abnf:bind-consumed->symbol (abnf.lit ss))
     459                          (abnf:drop-consumed (abnf.char #\:))
     460                          (abnf:drop-consumed
     461                           (abnf:repetition (abnf.char #\space)))
     462                          p
     463                          (abnf:drop-consumed abnf.crlf))
     464                         )))
    300465               
    301           (define p-server-software
     466
     467          (define (server-software product comment)
    302468            (abnf:bind-consumed->string
    303469             (abnf:repetition1
    304470              (abnf:alternatives
    305                product comment))))
     471               product comment))
     472             ))
     473
     474         
     475     ;; disposition := "Content-Disposition" ":"
     476     ;;                disposition-type
     477     ;;                *(";" disposition-parm)
     478
     479     ;; disposition-type := "inline"
     480     ;;                   / "attachment"
     481     ;;                   / extension-token
     482     ;;                   ; values are not case-sensitive
     483
     484     ;; disposition-parm := filename-parm
     485     ;;                   / creation-date-parm
     486     ;;                   / modification-date-parm
     487     ;;                   / read-date-parm
     488     ;;                   / size-parm
     489     ;;                   / parameter
     490
     491     ;; filename-parm := "filename" "=" value
     492
     493     ;; creation-date-parm := "creation-date" "=" quoted-date-time
     494
     495     ;; modification-date-parm := "modification-date" "=" quoted-date-time
     496
     497     ;; read-date-parm := "read-date" "=" quoted-date-time
     498
     499     ;; size-parm := "size" "=" 1*DIGIT
     500
     501     ;; quoted-date-time := quoted-string
     502     ;;                  ; contents MUST be an RFC 822 `date-time'
     503     ;;                  ; numeric timezones (+HHMM or -HHMM) MUST be
     504
     505
     506          (define=> (disposition-type (<CoreABNF> abnf.))
     507            (lambda (token)
     508              (abnf:bind-consumed-strings->list 'type
     509               (abnf:alternatives
     510                (abnf.lit "inline")
     511                (abnf.lit "attachment")
     512                (abnf:bind-consumed->string token)))
     513              ))
     514
     515               
     516
     517          (define=> (content-disposition (<CoreABNF> abnf.))
     518            (lambda (token quoted-string disposition-type)
     519              (let* (
     520                     (attribute  (abnf:bind-consumed->string token))
     521                     (value      (abnf:bind-consumed->string
     522                                  (abnf:alternatives token quoted-string)))
     523                     (parameter  (abnf:bind-consumed-strings->list
     524                                  (abnf:concatenation
     525                                   attribute
     526                                   (abnf:drop-consumed (abnf.char #\=))
     527                                   value)))
     528                     )
     529               
     530                (abnf:concatenation
     531                 disposition-type
     532                 (abnf:repetition
     533                  (abnf:concatenation
     534                   (abnf:drop-consumed
     535                    (abnf:concatenation
     536                     (abnf.char #\;)
     537                     (abnf:repetition
     538                      (abnf.set (char-set #\space #\tab)))
     539                     ))
     540                   parameter))
     541                 ))
     542              ))
    306543           
     544           
     545          (define (CoreABNF->CGI A)
     546            (let* ((token*        (token A))
     547                   (quoted-string* (quoted-string A))
     548                   (lchar*        (lchar A))
     549                   (lsegment*     (lsegment lchar*))
     550                   (path*         ((path A) lsegment*))
     551                   (escaped*      (escaped A))
     552                   (reserved*     (reserved A))
     553                   (mark*         (mark A))
     554                   (unreserved*   ((unreserved A) mark*))
     555                   (uric*         (uric reserved* unreserved* escaped*))
     556                   (query-string* (query-string uric))
     557                   (ddot*         (ddot A))
     558                   (dcolon*       (dcolon A))
     559                   (ipv4d*        (ipv4d A))
     560                   (ipv4-address* (ipv4-address ipv4d* ddot*))
     561                   (ipv6h*        (ipv6h A))
     562                   (hexseq*       (hexseq ipv6h* dcolon*))
     563                   (hexpart*      ((hexpart A) hexseq*))
     564                   (ipv6-address* (ipv6-address ipv4-address* hexpart* dcolon*))
     565                   (hostnumber*   (hostnumber ipv4-address* ipv6-address*))
     566                   (remote-addr*  hostnumber*)
     567                   (alphanum*     (alphanum A))
     568                   (alphahypdig*  (alphahypdigit A))
     569                   (server-name*  ((server-name A) ipv4-address* ipv6-address*))
     570                   (toplabel*     ((toplabel A) alphahypdig* alphanum))
     571                   (domainlabel*  (domainlabel alphahypdigit alphanum))
     572                   (hostname*     (hostname domainlabel toplabel ddot))
     573                   (extension-method* (extension-method A))
     574                   (method*        ((method A) extension-method*))
     575                   (request-method* (request-method method*))
     576                   (content-length* (content-length A))
     577                   (content-type*   ((content-type A) token* quoted-string*))
     578                   (disposition-type*  ((disposition-type A) token*))
     579                   (content-disposition*  ((content-disposition A) token* quoted-string* disposition-type*))
     580                   (comment*      (comment A))
     581                   (product*      (product A))
     582                   (header*       (header A))
     583                   )
     584
     585              (make-<CGI>  A
     586                           ((auth-type A) token*)
     587                           content-length*
     588                           content-type*
     589                           (gateway-interface A)
     590                           ((path-info A) path*)
     591                           query-string*
     592                           remote-addr*
     593                           (remote-host hostname* hostnumber*)
     594                           request-method*
     595                           server-name*
     596                           (server-port A)
     597                           (server-protocol A)
     598                           (server-software product* comment*)
     599                           (abnf:repetition
     600                            (abnf:alternatives
     601                             (header* "Content-Type" content-type*)
     602                             (header* "Content-Length" content-length*)
     603                             (header* "Content-Disposition" content-disposition*)
     604                             ))
     605                         )
     606              ))
    307607
    308608)
  • release/4/cgi/trunk/protocol.scm

    r29259 r29360  
    1 ;;
     1;
    22;;  An implementation of the CGI protocol as described in RFC 3875
    33;;  "The Common Gateway Interface (CGI) 1.1".
     
    3434        (import (only extras sprintf fprintf ))
    3535
    36         (require-extension byte-blob datatype cgi-environment)
     36        (require-extension byte-blob datatype typeclass input-classes cgi-environment)
     37
     38        (require-library lexgen abnf)
     39        (import (only abnf <CoreABNF> CharLex->CoreABNF)
     40                (only lexgen <Token> <CharLex> Input->Token Token->CharLex))
     41        (require-library cgi-grammar)
     42        (import (only cgi-grammar <CGI> CoreABNF->CGI))
     43       
    3744
    3845
     
    5663
    5764(define (request-inputs r)
    58   (case request r
     65  (cases request r
    5966        (Inputs (lst) lst)
    6067        (Body (b) #f)
     
    6370
    6471(define (request-body r)
    65   (case request r
    66         (Inputs (lst) #f)
    67         (Body (b) b)
    68         (InputsWithBody (i b) b)))
     72  (cases request r
     73         (Inputs (lst) #f)
     74         (Body (b) b)
     75         (InputsWithBody (i b) b)))
    6976
    7077
     
    232239
    233240
     241(define byte-blob-<Input>
     242  (make-<Input> byte-blob-empty?
     243                byte-blob-char-car
     244                byte-blob-char-cdr))
     245
     246(define byte-blob-<Token>
     247  (Input->Token byte-blob-<Input>))
     248
     249(define byte-blob-<CharLex>
     250  (Token->CharLex byte-blob-<Token>))
     251
     252(define byte-blob-<CoreABNF>
     253  (CharLex->CoreABNF byte-blob-<CharLex>))
     254
     255(define byte-blob-<CGI>
     256  (CoreABNF->CGI byte-blob-<CoreABNF> ))
     257
     258(import-instance (<CGI> byte-blob-<CGI> p.) )
     259
     260
    234261
    235262;; Runs a CGI action and returns its response.
     
    271298       
    272299(define (skip-line x)
    273   (byte-blob-char-trim (lambda (c) (not (char=? c #\newline))) x))
    274 
    275 (define (split-part x)
     300  (byte-blob-char-cdr (byte-blob-char-trim (lambda (c) (not (char=? c #\newline))) x)))
     301
     302
     303(define (split-part x)
     304  (p.part-headers
     305   identity
     306   (lambda (x) (error 'split-part "MIME part headers parser error" x))
     307   `(() ,x)
     308   ))
     309 
    276310
    277311(define (multipart-decode ps inp)
     
    280314        (let ((boundary1 (string->byte-blob (car boundary))))
    281315          (match-let (((prefix contents) (positions boundary1 inp)))
    282                      (let ((parts (map (lambda (x) (skip-line (car x))) contents)))
    283                        (map (lambda (part)
    284                               (match-let (((headers content) (split-part part)))
    285                                 (let ((ctype (alist-ref 'Content-type headers))
    286                                       (fn (alist-ref 'Content-disposition headers)))
    287                                   (Input content fn ctype))
    288                                 ))
    289                             parts)
     316                     (let ((parts
     317                            (filter-map
     318                             (lambda (x) (and (not (byte-blob-empty? (car x)))
     319                                              (skip-line (car x))))
     320                             contents)))
     321                       (let ((content
     322                              (map (lambda (part)
     323                                     (match-let (((headers content) (split-part part)))
     324                                                (let ((ctype (alist-ref 'Content-Type headers))
     325                                                      (fn (alist-ref 'Content-Disposition headers)))
     326                                                  (Input content fn ctype))
     327                                                ))
     328                                   parts)))
     329                         content)
    290330                       ))
    291331          ))
     
    298338  (match ctype
    299339         ((('type "multipart") ('subtype "form-data") . ps)
    300           (list (multipart-decode ps inp) #f))
     340          (let ((content (multipart-decode ps inp)))
     341            (list content  #f)))
    301342         ((('type "application") ('subtype "x-www-form-urlencoded"))
    302343          (list (form-input inp) #f))
Note: See TracChangeset for help on using the changeset viewer.