http.l (14592B)
1 # 23feb13abu 2 # (c) Software Lab. Alexander Burger 3 4 # *Home *Gate *Host *Port *Port1 *Port% *Http1 *Chunked 5 # *Sock *Agent *ContLen *MPartLim *MPartEnd "*HtSet" 6 # *Post *Url *Timeout *SesAdr *SesId *ConId 7 # *Referer *Cookies "*Cookies" 8 9 (default 10 *HPorts 0 11 *Timeout (* 300 1000) ) 12 13 (zero *Http1) 14 15 (de *Mimes 16 (`(chop "html") "text/html; charset=utf-8") 17 (`(chop "au") "audio/basic" 3600) 18 (`(chop "wav") "audio/x-wav" 3600) 19 (`(chop "mp3") "audio/x-mpeg" 3600) 20 (`(chop "gif") "image/gif" 3600) 21 (`(chop "tif") "image/tiff" 3600) 22 (`(chop "tiff") "image/tiff" 3600) 23 (`(chop "bmp") "image/bmp" 86400) 24 (`(chop "png") "image/png" 86400) 25 (`(chop "jpg") "image/jpeg" 3600) 26 (`(chop "jpeg") "image/jpeg" 3600) 27 (`(chop "txt") "text/octet-stream" 1 T) 28 (`(chop "csv") "text/csv; charset=utf-8" 1 T) 29 (`(chop "css") "text/css" 3600) 30 (`(chop "js") "application/x-javascript" 86400) 31 (`(chop "ps") "application/postscript" 1) 32 (`(chop "pdf") "application/pdf" 1) 33 (`(chop "zip") "application/zip" 1) 34 (`(chop "jar") "application/java-archive" 86400) ) 35 36 (de mime (S . @) 37 (let L (chop S) 38 (if (assoc L *Mimes) 39 (con @ (rest)) 40 (push '*Mimes (cons L (rest))) ) ) ) 41 42 (de mimetype (File) 43 (in (list 'file "--brief" "--mime" File) 44 (line T) ) ) 45 46 ### HTTP-Client ### 47 (de client (Host Port How . Prg) 48 (let? Sock (connect Host Port) 49 (prog1 50 (out Sock 51 (if (atom How) 52 (prinl "GET /" How " HTTP/1.0^M") 53 (prinl "POST /" (car How) " HTTP/1.0^M") 54 (prinl "Content-Length: " (size (cdr How)) "^M") ) 55 (prinl "User-Agent: PicoLisp^M") 56 (prinl "Host: " Host "^M") 57 (prinl "Accept-Charset: utf-8^M") 58 (prinl "^M") 59 (and (pair How) (prin (cdr @))) 60 (flush) 61 (in Sock (run Prg 1)) ) 62 (close Sock) ) ) ) 63 64 # Local Password 65 (de pw (N) 66 (if N 67 (out ".pw" (prinl (fmt64 (in "/dev/urandom" (rd N))))) 68 (in ".pw" (line T)) ) ) 69 70 # PicoLisp Shell 71 (de psh (Pw Tty) 72 (off *Run) 73 (when (and (= Pw (pw)) (ctty Tty)) 74 (prinl *Pid) 75 (load "@dbg.l") 76 (off *Err) 77 (quit) ) ) 78 79 ### HTTP-Server ### 80 (de -server () 81 (server (format (opt)) (opt)) ) 82 83 (de server (P H) 84 (setq 85 *Port P 86 *Port1 P 87 *Home (cons H (chop H)) 88 P (port *Port) ) 89 (gc) 90 (loop 91 (setq *Sock (listen P)) 92 (NIL (fork) (close P)) 93 (close *Sock) ) 94 (task *Sock (http @)) 95 (http *Sock) 96 (or *SesId (bye)) 97 (task *Sock 98 (when (accept *Sock) 99 (task @ (http @)) ) ) ) 100 101 (de baseHRef (Port . @) 102 (pass pack 103 (or *Gate "http") "://" *Host 104 (if *Gate "/" ":") (or Port *Port) "/" ) ) 105 106 (de https @ 107 (pass pack "https://" *Host "/" *Port "/" *SesId) ) 108 109 (de ext.html (Sym) 110 (pack (ht:Fmt Sym) ".html") ) 111 112 (de disallowed () 113 (and 114 *Allow 115 (not (idx *Allow *Url)) 116 (or 117 (sub? ".." *Url) 118 (nor 119 (and *Tmp (pre? *Tmp *Url)) 120 (find pre? (cdr *Allow) (circ *Url)) ) ) ) ) 121 122 (de notAllowed (X S) 123 (unless (= X "favicon.ico") 124 (msg X S " [" *Adr "] not allowed") ) ) 125 126 # Application startup 127 (de app () 128 (unless *SesId 129 (setq 130 *Port% (not *Gate) 131 *SesAdr *Adr 132 *SesId (pack (in "/dev/urandom" (rd 7)) "~") 133 *Sock (port *HPorts '*Port) ) 134 (timeout *Timeout) ) ) 135 136 # Set a cookie 137 (de cookie @ 138 (if (assoc (next) "*Cookies") 139 (con @ (rest)) 140 (push '"*Cookies" (cons (arg) (rest))) ) ) 141 142 # Handle HTTP-Transaction 143 (de http (S) 144 (use (*Post L @U @H @X) 145 (off *Post *Port% *ContLen *Cookies "*Cookies" "*HtSet") 146 (catch "http" 147 (in S 148 (cond 149 ((not (setq L (line))) 150 (task (close S)) 151 (off S) 152 (throw "http") ) 153 ((match '("G" "E" "T" " " "/" @U " " "H" "T" "T" "P" "/" "1" "." @H) L) 154 (_htHead) ) 155 ((match '("P" "O" "S" "T" " " "/" @U " " "H" "T" "T" "P" "/" "1" "." @H) L) 156 (on *Post) 157 (off *MPartLim *MPartEnd) 158 (_htHead) 159 (cond 160 (*MPartLim (_htMultipart)) 161 ((=0 *ContLen)) 162 ((if *ContLen (ht:Read @) (line)) 163 (for L (split @ '&) 164 (when (setq L (split L "=")) 165 (let? S (_htSet (car L) (ht:Pack (cadr L))) 166 (and 167 (cddr L) 168 (format (car @)) 169 (unless (out (tmp S) (echo @)) 170 (call 'rm "-f" (tmp S)) ) ) ) ) ) ) 171 (T (throw "http")) ) ) 172 (T 173 (out S 174 (if 175 (and 176 (match '(@U " " @ " " "H" "T" "T" "P" . @) L) 177 (member @U 178 (quote 179 ("O" "P" "T" "I" "O" "N" "S") 180 ("H" "E" "A" "D") 181 ("P" "U" "T") 182 ("D" "E" "L" "E" "T" "E") 183 ("T" "R" "A" "C" "E") 184 ("C" "O" "N" "N" "E" "C" "T") ) ) ) 185 (httpStat 501 "Method Not Implemented" "Allow: GET, POST") 186 (httpStat 400 "Bad Request") ) ) 187 (task (close S)) 188 (off S) 189 (throw "http") ) ) 190 (if (or (<> *ConId *SesId) (and *SesAdr (<> @ *Adr))) 191 (prog (task (close S)) (off S)) 192 (setq 193 L (split @U "?") 194 @U (car L) 195 L (mapcan 196 '((A) 197 (cond 198 ((cdr (setq A (split A "="))) 199 (nil (_htSet (car A) (htArg (cadr A)))) ) 200 ((tail '`(chop ".html") (car A)) 201 (cons (pack (car A))) ) 202 (T (cons (htArg (car A)))) ) ) 203 (split (cadr L) "&") ) ) 204 (unless (setq *Url (ht:Pack @U)) 205 (setq *Url (car *Home) @U (cdr *Home)) ) 206 (out S 207 (cond 208 ((match '("-" @X "." "h" "t" "m" "l") @U) 209 (and *SesId (timeout *Timeout)) 210 (apply try L 'html> (extern (ht:Pack @X))) ) 211 ((disallowed) 212 (notAllowed *Url) 213 (http404) ) 214 ((= '! (car @U)) 215 (and *SesId (timeout *Timeout)) 216 (apply (val (intern (ht:Pack (cdr @U)))) L) ) 217 ((tail '("." "l") @U) 218 (and *SesId (timeout *Timeout)) 219 (apply script L *Url) ) 220 ((=T (car (info *Url))) 221 (if (info (setq *Url (pack *Url "/default"))) 222 (apply script L *Url) 223 (http404) ) ) 224 ((assoc (stem @U ".") *Mimes) 225 (apply httpEcho (cdr @) *Url) ) 226 (T (httpEcho *Url "application/octet-stream" 1 T)) ) ) ) ) ) 227 (and S (=0 *Http1) (task (close S))) ) ) 228 229 (de _htHost H 230 (setq *Host 231 (cond 232 (*Gate H) 233 ((index ":" H) (head (dec @) H)) 234 (T H) ) ) ) 235 236 (de _htHead () 237 (use (L @X @Y Pil) 238 (setq *Http1 (format (car @H)) *Chunked (gt0 *Http1) Pil) 239 (if (index "~" @U) 240 (setq 241 *ConId (head @ @U) 242 @U (cdr (nth @U @)) 243 *ConId (pack (if (member "/" *ConId) (cdr @) *ConId)) ) 244 (off *ConId) ) 245 (while (setq L (line)) 246 (cond 247 ((match '(~(chop "Host: ") . @X) L) 248 (fifo 'Pil (cons '_htHost @X)) ) 249 ((match '(~(chop "Referer: ") . @X) L) 250 (setq *Referer @X) ) 251 ((match '(~(chop "Cookie: ") . @X) L) 252 (setq *Cookies 253 (mapcar 254 '((L) 255 (setq L (split L "=")) 256 (cons (htArg (clip (car L))) (htArg (cadr L))) ) 257 (split @X ";") ) ) ) 258 ((match '(~(chop "User-Agent: ") . @X) L) 259 (setq *Agent @X) ) 260 ((match '(~(chop "Content-@ength: ") . @X) L) 261 (setq *ContLen (format @X)) ) 262 ((match '(~(chop "Content-@ype: multipart/form-data; boundary=") . @X) L) 263 (setq 264 *MPartLim (append '(- -) @X) 265 *MPartEnd (append *MPartLim '(- -)) ) ) 266 ((match '(~(chop "X-Pil: ") @X "=" . @Y) L) 267 (fifo 'Pil (list 'setq (intern (pack @X)) (htArg @Y))) ) ) ) 268 (while Pil 269 (eval (fifo 'Pil)) ) ) ) 270 271 # rfc1867 multipart/form-data 272 (de _htMultipart () 273 (use (L @X @N @V) 274 (setq L (line)) 275 (while (= *MPartLim L) 276 (unless (match '(~(chop "Content-Disposition: form-data; name=") . @X) (line)) 277 (throw "http") ) 278 (while (line)) 279 (cond 280 ((not (member ";" @X)) 281 (match '("\"" @X "\"") @X) 282 (_htSet @X 283 (pack 284 (make 285 (until 286 (or 287 (= *MPartLim (setq L (line))) 288 (= *MPartEnd L) ) 289 (when (eof) 290 (throw "http") ) 291 (when (made) 292 (link "^J") ) 293 (link (trim L)) ) ) ) ) ) 294 ((match '(@N ~(chop "; filename=") . @V) @X) 295 (match '("\"" @N "\"") @N) 296 (match '("\"" @V "\"") @V) 297 (if (_htSet @N (pack (stem @V "/" "\\"))) 298 (let F (tmp @) 299 (unless (out F (echo (pack "^M^J" *MPartLim))) 300 (call 'rm "-f" F) ) ) 301 (out "/dev/null" (echo (pack "^M^J" *MPartLim))) ) 302 (setq L (if (= "-" (car (line))) *MPartEnd *MPartLim)) ) ) ) ) ) 303 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")) ) ) ) 319 (cond 320 ((and *Allow (not (idx *Allow "Var"))) 321 (notAllowed "Var" ':) 322 (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))) ) ) ) 339 (T 340 (queue "Var" (cons @N Val)) 341 Val ) ) ) ) 342 343 (de htArg (Lst) 344 (case (car Lst) 345 ("$" (intern (ht:Pack (cdr Lst)))) 346 ("+" (format (cdr Lst))) 347 ("-" (extern (ht:Pack (cdr Lst)))) 348 ("_" (mapcar htArg (split (cdr Lst) "_"))) 349 (T (ht:Pack Lst)) ) ) 350 351 # Http Transfer Header 352 (de http1 (Typ Upd File Att) 353 (prinl "HTTP/1." *Http1 " 200 OK^M") 354 (prinl "Server: PicoLisp^M") 355 (prin "Date: ") 356 (httpDate (date T) (time T)) 357 (when Upd 358 (prinl "Cache-Control: max-age=" Upd "^M") 359 (when (=0 Upd) 360 (prinl "Cache-Control: private, no-store, no-cache^M") ) ) 361 (prinl "Content-Type: " (or Typ "text/html; charset=utf-8") "^M") 362 (when File 363 (prinl 364 "Content-Disposition: " 365 (if Att "attachment" "inline") 366 "; filename=\"" File "\"^M" ) ) ) 367 368 (de httpCookies () 369 (mapc 370 '((L) 371 (prin "Set-Cookie: " 372 (ht:Fmt (pop 'L)) "=" (ht:Fmt (pop 'L)) 373 "; path=" (or (pop 'L) "/") ) 374 (and (pop 'L) (prin "; expires=" @)) 375 (and (pop 'L) (prin "; domain=" @)) 376 (and (pop 'L) (prin "; secure")) 377 (and (pop 'L) (prin "; HttpOnly")) 378 (prinl) ) 379 "*Cookies" ) ) 380 381 (de httpHead (Typ Upd File Att) 382 (http1 Typ Upd File Att) 383 (and *Chunked (prinl "Transfer-Encoding: chunked^M")) 384 (httpCookies) 385 (prinl "^M") ) 386 387 (de httpDate (Dat Tim) 388 (let D (date Dat) 389 (prinl 390 (day Dat *Day) ", " 391 (pad 2 (caddr D)) " " 392 (get *Mon (cadr D)) " " 393 (car D) " " 394 (tim$ Tim T) " GMT^M" ) ) ) 395 396 # Http Echo 397 (de httpEcho (File Typ Upd Att) 398 (and *Tmp (pre? *Tmp File) (one Upd)) 399 (ifn (info File) 400 (http404) 401 (let I @ 402 (http1 (or Typ (mimetype File)) Upd (stem (chop File) "/") Att) 403 (prinl "Content-Length: " (car I) "^M") 404 (prin "Last-Modified: ") 405 (httpDate (cadr I) (cddr I)) 406 (prinl "^M") 407 (in File (echo)) ) ) ) 408 409 (de srcUrl (Url) 410 (if (or (pre? "http:" Url) (pre? "https:" Url)) 411 Url 412 (baseHRef *Port1 Url) ) ) 413 414 (de sesId (Url) 415 (if 416 (or 417 (pre? "http:" Url) 418 (pre? "https:" Url) 419 (pre? "mailto:" Url) 420 (pre? "javascript:" Url) ) 421 Url 422 (pack *SesId Url) ) ) 423 424 (de httpStat (N Str . @) 425 (prinl "HTTP/1." *Http1 " " N " " Str "^M") 426 (prinl "Server: PicoLisp^M") 427 (while (args) 428 (prinl (next) "^M") ) 429 (prinl "Content-Type: text/html^M") 430 (httpCookies) 431 (prinl "Content-Length: " (+ 68 (length N) (* 2 (length Str))) "^M") 432 (prinl "^M") 433 (prinl "<HTML>") 434 (prinl "<HEAD><TITLE>" N " " Str "</TITLE></HEAD>") 435 (prinl "<BODY><H1>" Str "</H1></BODY>") 436 (prinl "</HTML>") ) 437 438 (de noContent () 439 (httpStat 204 "No Content") ) 440 441 (de redirect @ 442 (httpStat 303 "See Other" (pass pack "Location: ")) ) 443 444 (de forbidden () 445 (httpStat 403 "No Permission") 446 (throw "http") ) 447 448 (de http404 () 449 (httpStat 404 "Not Found") ) 450 451 ### Debug ### 452 `*Dbg 453 (noLint 'http '"O") 454 455 # vi:et:ts=3:sw=3