← Back to branch summary

~ubuntu-branches/debian/sid/picolisp/sid

« back to all changes in this revision

Viewing changes to lib/http.l

  • Committer: Package Import Robot
  • Author(s): Kan-Ru Chen (陳侃如)
  • Date: 2014-01-15 00:41:33 UTC
  • mfrom: (1.1.26)
  • Revision ID: package-import@ubuntu.com-20140115004133-gpnyej505j0z8808
Tags: 3.1.5.2-1
* New upstream release.
* Refresh patches.
* debian/control:
  - Bump Standards-Version to 3.9.5.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/http.l
1
 
# 25oct13abu
 
1
# 01jan14abu
2
2
# (c) Software Lab. Alexander Burger
3
3
 
4
4
# *Home *Gate *Host *Port *Port1 *Port% *Http1 *Chunked
5
 
# *Sock *Agent *ContLen *MPartLim *MPartEnd "*HtSet"
 
5
# *Sock *Agent *ContL *ContLen *MPartLim *MPartEnd "*HtSet"
6
6
# *Post *Url *Timeout *SesAdr *SesId *ConId
7
7
# *Referer *Cookies "*Cookies"
8
8
 
10
10
   *HPorts 0
11
11
   *Timeout (* 300 1000) )
12
12
 
 
13
(mapc allow '(*Adr *Gate *Host *ContL))
 
14
 
13
15
(zero *Http1)
14
16
 
15
17
(de *Mimes
119
121
            (and *Tmp (pre? *Tmp *Url))
120
122
            (find pre? (cdr *Allow) (circ *Url)) ) ) ) )
121
123
 
122
 
(de notAllowed (X S)
 
124
(de notAllowed (X)
123
125
   (unless (= X "favicon.ico")
124
 
      (msg X S " [" *Adr "] not allowed") ) )
 
126
      (msg X " [" *Adr "] not allowed") ) )
125
127
 
126
128
# Application startup
127
129
(de app ()
142
144
# Handle HTTP-Transaction
143
145
(de http (S)
144
146
   (use (*Post L @U @H @X)
145
 
      (off *Post *Port% *ContLen *Cookies "*Cookies" "*HtSet")
 
147
      (off *Post *Port% *ContL *ContLen *Cookies "*Cookies" "*HtSet")
146
148
      (catch 'http
147
149
         (in S
148
150
            (cond
159
161
                  (cond
160
162
                     (*MPartLim (_htMultipart))
161
163
                     ((=0 *ContLen))
162
 
                     ((if *ContLen (ht:Read @) (line))
 
164
                     ((cond (*ContL (line)) (*ContLen (ht:Read @)))
163
165
                        (for L (split @ '&)
164
166
                           (when (setq L (split L "="))
165
167
                              (let? S (_htSet (car L) (ht:Pack (cadr L)))
226
228
                     (T (httpEcho *Url "application/octet-stream" 1 T)) ) ) ) ) )
227
229
      (and S (=0 *Http1) (task (close S))) ) )
228
230
 
229
 
(de _htHost H
230
 
   (setq *Host
231
 
      (cond
232
 
         (*Gate H)
233
 
         ((index ":" H) (head (dec @) H))
234
 
         (T H) ) ) )
235
 
 
236
231
(de _htHead ()
237
 
   (use (L @X @Y Pil)
238
 
      (setq *Http1 (format (car @H))  *Chunked (gt0 *Http1)  Pil)
 
232
   (use (L @X @Y)
 
233
      (setq *Http1 (format (car @H))  *Chunked (gt0 *Http1))
239
234
      (if (index "~" @U)
240
235
         (setq
241
236
            *ConId (head @ @U)
245
240
      (while (setq L (line))
246
241
         (cond
247
242
            ((match '(~(chop "Host: ") . @X) L)
248
 
               (fifo 'Pil (cons '_htHost @X)) )
 
243
               (setq *Host @X) )
249
244
            ((match '(~(chop "Referer: ") . @X) L)
250
245
               (setq *Referer @X) )
251
246
            ((match '(~(chop "Cookie: ") . @X) L)
264
259
                  *MPartLim (append '(- -) @X)
265
260
                  *MPartEnd (append *MPartLim '(- -)) ) )
266
261
            ((match '(~(chop "X-Pil: ") @X "=" . @Y) L)
267
 
               (fifo 'Pil (list 'setq (intern (pack @X)) (htArg @Y))) ) ) )
268
 
      (while Pil
269
 
         (eval (fifo 'Pil)) ) ) )
 
262
               (_htSet @X (ht:Pack @Y)) ) ) )
 
263
      (unless *Gate
 
264
         (and (member ":" *Host) (con (prior @ *Host))) ) ) )
270
265
 
271
266
# rfc1867 multipart/form-data
272
267
(de _htMultipart ()
301
296
                  (out "/dev/null" (echo (pack "^M^J" *MPartLim))) )
302
297
               (setq L (if (= "-" (car (line))) *MPartEnd *MPartLim)) ) ) ) ) )
303
298
 
304
 
(de _htSet ("Var" Val)
305
 
   (let (@N NIL  @Z NIL  @V)
306
 
      (setq "Var"
307
 
         (intern
308
 
            (ht:Pack
309
 
               (ifn (match '(@V ":" @N ":" @Z) "Var")
310
 
                  "Var"
311
 
                  (setq @N (format @N))
312
 
                  @V ) ) ) )
313
 
      (when @Z
314
 
         (setq Val
315
 
            (cond
316
 
               ((= @Z '("." "x")) (cons (format Val)))
317
 
               ((= @Z '("." "y")) (cons NIL (format Val)))
318
 
               (T (msg @Z " bad suffix") (throw 'http)) ) ) )
 
299
(de _htSet (L Val)
 
300
   (let "Var" (intern (ht:Pack (car (setq L (split L ":")))))
319
301
      (cond
320
302
         ((and *Allow (not (idx *Allow "Var")))
321
 
            (notAllowed "Var" ':)
 
303
            (notAllowed "Var")
322
304
            (throw 'http) )
323
 
         ((not @N)
324
 
            (nond
325
 
               ((= `(char '*) (char "Var")) (put "Var" 'http Val))
326
 
               ((and @Z (val "Var")) (set "Var" Val))
327
 
               ((car Val) (con (val "Var") (cdr Val)))
328
 
               (NIL (set (val "Var") (car Val))) ) )
329
 
         ((not (memq "Var" "*HtSet"))
330
 
            (push '"*HtSet" "Var")
331
 
            (set "Var" (cons (cons @N Val)))
332
 
            Val )
333
 
         ((assoc @N (val "Var"))
334
 
            (let X @
335
 
               (cond
336
 
                  ((nand @Z (cdr X)) (con X Val))
337
 
                  ((car Val) (set (cdr X) @))
338
 
                  (T (con (cdr X) (cdr Val))) ) ) )
 
305
         ((cadr L)
 
306
            (let? N (format (car (setq L (split @ "."))))
 
307
               (case (caadr L)
 
308
                  ("x" (setq Val (cons (format Val))))
 
309
                  ("y" (setq Val (cons NIL (format Val)))) )
 
310
               (nond
 
311
                  ((memq "Var" "*HtSet")
 
312
                     (push '"*HtSet" "Var")
 
313
                     (set "Var" (cons (cons N Val)))
 
314
                     Val )
 
315
                  ((assoc N (val "Var"))
 
316
                     (queue "Var" (cons N Val))
 
317
                     Val )
 
318
                  (NIL
 
319
                     (let X @
 
320
                        (cond
 
321
                           ((nand (cadr L) (cdr X)) (con X Val))
 
322
                           ((car Val) (set (cdr X) @))
 
323
                           (T (con (cdr X) (cdr Val))) ) ) ) ) ) )
339
324
         (T
340
 
            (queue "Var" (cons @N Val))
341
 
            Val ) ) ) )
 
325
            (if (= "*" (caar L))
 
326
               (set "Var" Val)
 
327
               (put "Var" 'http Val) ) ) ) ) )
342
328
 
343
329
(de htArg (Lst)
344
330
   (case (car Lst)
378
364
         (prinl) )
379
365
      "*Cookies" ) )
380
366
 
 
367
(de respond (S)
 
368
   (http1 "application/octet-stream" 0)
 
369
   (prinl "Content-Length: " (size S) "^M^J^M")
 
370
   (prin S) )
 
371
 
381
372
(de httpHead (Typ Upd File Att)
382
373
   (http1 Typ Upd File Att)
383
374
   (and *Chunked (prinl "Transfer-Encoding: chunked^M"))