Read This! | Picolisp | Picolisp Machine | Pil Sources | Pil Tutorials | Picolisp By Example | Linux | BASH | C-Programmming | Javascipt | Python | Scheme | Operating Systems | AssemblyLanguage | Computer Security | Firewalls | Exploitation | Social Engineering | Metasploit | Emacs | vim | Pharo Smalltalk | Databases | Networking | Machine Learning | Git | Machine Learning | Algorithms | Open Data Science |
http.l
# 24nov16abu # (c) Software Lab. Alexander Burger # *HPorts *Home *Gate *Host *Port *Port1 *Port% *Http1 *Chunked # *Sock *Agent *ContL *ContLen *MPartLim *MPartEnd "*HtSet" # *Post *Url *Timeout *SesAdr *SesId *ConId # *Referer *Cookies "*Cookies" (default *HPorts 0 *Timeout (* 300 1000) ) (mapc allow '(*Adr *Gate *Cipher *Host *ContL)) (zero *Http1) (de *Mimes (`(chop "html") "text/html; charset=utf-8") (`(chop "svg") "image/svg+xml; charset=utf-8") (`(chop "au") "audio/basic" 3600) (`(chop "wav") "audio/x-wav" 3600) (`(chop "mp3") "audio/x-mpeg" 3600) (`(chop "gif") "image/gif" 3600) (`(chop "tif") "image/tiff" 3600) (`(chop "tiff") "image/tiff" 3600) (`(chop "bmp") "image/bmp" 86400) (`(chop "png") "image/png" 86400) (`(chop "jpg") "image/jpeg" 3600) (`(chop "jpeg") "image/jpeg" 3600) (`(chop "txt") "text/octet-stream" 1 T) (`(chop "csv") "text/csv; charset=utf-8" 1 T) (`(chop "css") "text/css" 3600) (`(chop "js") "application/x-javascript" 86400) (`(chop "ps") "application/postscript" 1) (`(chop "pdf") "application/pdf" 1) (`(chop "zip") "application/zip" 1) (`(chop "jar") "application/java-archive" 86400) ) (de mime (S . @) (let L (chop S) (if (assoc L *Mimes) (con @ (rest)) (push '*Mimes (cons L (rest))) ) ) ) (de mimetype (File Typ) (in (list 'file "-b" (if Typ "--mime-type" "--mime") File) (line T) ) ) ### HTTP-Client ### (de client (Host Port How . Prg) (let? Sock (connect Host Port) (prog1 (out Sock (if (atom How) (prinl "GET /" How " HTTP/1.0^M") (prinl "POST /" (car How) " HTTP/1.0^M") (prinl "Content-Length: " (size (cdr How)) "^M") ) (prinl "User-Agent: PicoLisp^M") (prinl "Host: " Host "^M") (prinl "Accept-Charset: utf-8^M") (prinl "^M") (and (pair How) (prin (cdr @))) (flush) (in Sock (run Prg 1)) ) (close Sock) ) ) ) # Local Password (de pw (N) (if N (out ".pw" (prinl (in "/dev/urandom" (rd N)))) (in ".pw" (line T)) ) ) # PicoLisp Shell (de psh (Pw Tty) (nond (Pw (println *Port) (bye)) ((nand (= Pw (pw)) (ctty Tty)) (off *Run) (println *Pid) (load (if *Dbg "@lib/too.l" "@dbg.l")) (off *Err) (quit) ) ) ) ### HTTP-Server ### (de -server () (server (format (opt)) (opt)) ) (de server (P H) (setq *Port P *Port1 (or (sys "NAME") P) *Home (cons H (chop H)) P (port *Port) ) (gc) (loop (setq *Sock (listen P)) (NIL (fork) (close P)) (close *Sock) ) (task *Sock (http @)) (http *Sock) (or *SesId (bye)) (task *Sock (when (accept *Sock) (task @ (http @)) ) ) ) (de retire (Min . Prg) (when (sys "PORT") (task -60000 60000 X (cons Min Min Prg) (cond (*Adr (off *Adr) (set X (cadr X))) ((kids) (set X (cadr X))) ((=0 (dec X)) (run (cddr X)) (bye)) ) ) (forked) ) ) (de baseHRef (Port . @) (pass pack (or *Gate "http") "://" *Host (if *Gate "/" ":") (or Port (if *SesId *Port *Port1)) "/" ) ) (de https @ (pass pack "https://" *Host "/" *Port "/" *SesId) ) (de ext.html (Sym) (pack (ht:Fmt Sym) ".html") ) (de disallowed () (and *Allow (not (idx *Allow *Url)) (or (sub? ".." *Url) (nor (and *Tmp (pre? *Tmp *Url)) (find pre? (cdr *Allow) (circ *Url)) ) ) ) ) (de notAllowed (X) (unless (= X "favicon.ico") (msg X " [" *Adr "] not allowed") ) ) # Application startup (de app () (unless *SesId (setq *Port% (not *Gate) *SesAdr *Adr *SesId (pack (in "/dev/urandom" (rd 7)) "~") *Sock (port *HPorts '*Port) ) (timeout *Timeout) ) ) # Set a cookie (de cookie @ (if (assoc (next) "*Cookies") (con @ (rest)) (push '"*Cookies" (cons (arg) (rest))) ) ) # Handle HTTP-Transaction (de http (S) (use (*Post U L @X) (off *Post *Port% *ContL *ContLen *Cookies "*Cookies" "*HtSet") (catch 'http (in S (case (till " " T) ("GET" (_htHead)) ("POST" (on *Post) (off *MPartLim *MPartEnd) (_htHead) (cond (*MPartLim (_htMultipart)) ((=0 *ContLen)) ((cond (*ContL (line)) (*ContLen (ht:Read @))) (for L (split @ '&) (when (setq L (split L "=")) (let? S (_htSet (car L) (ht:Pack (cadr L) T)) (and (cddr L) (format (car @)) (unless (out (tmp S) (echo @)) (call "rm" "-f" (tmp S)) ) ) ) ) ) ) (T (throw 'http)) ) ) (T (and @ (out S (httpStat 400 "Bad Request"))) (task (close S)) (off S) (throw 'http) ) ) (if (or (<> *ConId *SesId) (and *SesAdr (<> @ *Adr))) (prog (task (close S)) (off S)) (setq L (split U "?") U (car L) L (mapcan '((A) (cond ((cdr (setq A (split A "="))) (nil (_htSet (car A) (htArg (cadr A)))) ) ((tail '`(chop ".html") (car A)) (cons (pack (car A))) ) (T (cons (htArg (car A)))) ) ) (split (cadr L) "&") ) ) (unless (setq *Url (ht:Pack U T)) (setq *Url (car *Home) U (cdr *Home)) ) (out S (cond ((match '("-" @X "." "h" "t" "m" "l") U) (and *SesId (timeout *Timeout)) (apply try L 'html> (extern (ht:Pack @X T))) ) ((disallowed) (notAllowed *Url) (http404) ) ((= "!" (car U)) (and *SesId (timeout *Timeout)) (apply (val (intern (ht:Pack (cdr U) T))) L) ) ((tail '("." "l") U) (and *SesId (timeout *Timeout)) (apply script L *Url) ) ((=T (car (info *Url))) (if (info (setq *Url (pack *Url "/default"))) (apply script L *Url) (http404) ) ) ((assoc (stem U ".") *Mimes) (apply httpEcho (cdr @) *Url) ) (T (httpEcho *Url "application/octet-stream" 1 T)) ) ) ) ) ) (and S (=0 *Http1) (task (close S))) ) ) (de _htHead () (unless (and (char) (= "/" (char)) (prog (setq U (till " ")) (char)) (= "HTTP/1" (till "." T)) (char) (setq *Http1 (format (line T))) ) (task (close S)) (off S) (throw 'http) ) (setq *Chunked (gt0 *Http1)) (if (index "~" U) (setq *ConId (head @ U) U (cdr (nth U @)) *ConId (pack (if (member "/" *ConId) (cdr @) *ConId)) ) (off *ConId) ) (while (case (lowc (till " ^M^J" T)) ("host:" (setq *Host (cdr (line)))) ("referer:" (setq *Referer (cdr (line)))) ("cookie:" (setq *Cookies (mapcar '((L) (setq L (split L "=")) (cons (htArg (clip (car L))) (htArg (cadr L))) ) (split (cdr (line)) ";") ) ) ) ("user-agent:" (setq *Agent (cdr (line)))) ("content-length:" (setq *ContLen (format (cdr (line))))) ("content-type:" (if (= " multipart/form-data; boundary" (lowc (till "=" T))) (setq *MPartLim (append '(- -) (cdr (line))) *MPartEnd (append *MPartLim '(- -)) ) (line) ) ) ("x-pil:" (char) (when (till "=") (_htSet @ (ht:Pack (cdr (line)) T)) T ) ) (T (if (eol) (char) (line T))) ) ) (unless *Gate (and (member ":" *Host) (con (prior @ *Host))) ) ) # rfc1867 multipart/form-data (de _htMultipart () (use Var (let L (line) (while (= *MPartLim L) (unless (= "content-disposition: form-data; name=" (lowc (till """ T))) (line) (throw 'http) ) (char) (setq Var (till """)) (char) (nond ((line) (while (line)) (_htSet Var (pack (make (until (or (= *MPartLim (setq L (line))) (= *MPartEnd L) ) (when (eof) (throw 'http) ) (when (made) (link "^J") ) (link (trim L)) ) ) ) ) ) ((head '`(chop "; filename=") (setq L @)) (while (line)) ) (NIL (while (line)) (setq L (cdr (rot (nth L 13)))) (if (_htSet Var (pack (stem L "/" "\"))) (let F (tmp @) (unless (out F (echo (pack "^M^J" *MPartLim))) (call "rm" "-f" F) ) ) (out "/dev/null" (echo (pack "^M^J" *MPartLim))) ) (setq L (if (= "-" (car (line))) *MPartEnd *MPartLim)) ) ) ) ) ) ) (de _htSet (L Val) (let "Var" (intern (ht:Pack (car (setq L (split L ":"))) T)) (cond ((and *Allow (not (idx *Allow "Var"))) (notAllowed "Var") (throw 'http) ) ((cadr L) (let? N (format (car (setq L (split @ ".")))) (case (caadr L) ("x" (setq Val (cons (format Val)))) ("y" (setq Val (cons NIL (format Val)))) ) (nond ((memq "Var" "*HtSet") (push '"*HtSet" "Var") (set "Var" (cons (cons N Val))) Val ) ((assoc N (val "Var")) (queue "Var" (cons N Val)) Val ) (NIL (let X @ (cond ((nand (cadr L) (cdr X)) (con X Val)) ((car Val) (set (cdr X) @)) (T (con (cdr X) (cdr Val))) ) ) ) ) ) ) (T (if (= "*" (caar L)) (set "Var" Val) (put "Var" 'http Val) ) ) ) ) ) (de htArg (Lst) (case (car Lst) ("$" (intern (ht:Pack (cdr Lst) T))) ("+" (format (cdr Lst))) ("-" (extern (ht:Pack (cdr Lst) T))) ("_" (mapcar htArg (split (cdr Lst) "_"))) (T (ht:Pack Lst T)) ) ) # Http Transfer Header (de http1 (Typ Upd File Att) (prinl "HTTP/1." *Http1 " 200 OK^M") (prinl "Server: PicoLisp^M") (prin "Date: ") (httpDate (date T) (time T)) (when Upd (prinl "Cache-Control: max-age=" Upd "^M") (when (=0 Upd) (prinl "Cache-Control: private, no-store, no-cache^M") ) ) (prinl "Content-Type: " (or Typ "text/html; charset=utf-8") "^M") (when File (prinl "Content-Disposition: " (if Att "attachment" "inline") "; filename="" File ""^M" ) ) ) (de httpCookies () (mapc '((L) (prin "Set-Cookie: " (ht:Fmt (++ L)) "=" (ht:Fmt (++ L)) "; path=" (or (++ L) "/") ) (and (++ L) (prin "; expires=" @)) (and (++ L) (prin "; domain=" @)) (and (++ L) (prin "; secure")) (and (++ L) (prin "; HttpOnly")) (prinl) ) "*Cookies" ) ) (de respond (S) (http1 "application/octet-stream" 0) (prinl "Content-Length: " (size S) "^M^J^M") (prin S) ) (de httpHead (Typ Upd File Att) (http1 Typ Upd File Att) (and *Chunked (prinl "Transfer-Encoding: chunked^M")) (httpCookies) (prinl "^M") ) (de httpDate (Dat Tim) (let D (date Dat) (prinl (day Dat *Day) ", " (pad 2 (caddr D)) " " (get *Mon (cadr D)) " " (car D) " " (tim$ Tim T) " GMT^M" ) ) ) # Http Echo (de httpEcho (File Typ Upd Att) (and *Tmp (pre? *Tmp File) (one Upd)) (ifn (info File) (http404) (let I @ (http1 (or Typ (mimetype File)) Upd (stem (chop File) "/") Att) (prinl "Content-Length: " (car I) "^M") (prin "Last-Modified: ") (httpDate (cadr I) (cddr I)) (prinl "^M") (in File (echo)) ) ) ) (de srcUrl (Url) (if (or (pre? "http:" Url) (pre? "https:" Url)) Url (baseHRef *Port1 Url) ) ) (de sesId (Url) (if (or (pre? "http:" Url) (pre? "https:" Url) (pre? "mailto:" Url) (pre? "javascript:" Url) (pre? "tel:" Url) ) Url (pack *SesId Url) ) ) (de httpStat (N X . @) (let B (fin X) (if (pair X) (setq X (car X)) (setq B (pack "<H1>" B "</H1>")) ) (prinl "HTTP/1." *Http1 " " N " " X "^M") (prinl "Server: PicoLisp^M") (while (args) (prinl (next) "^M") ) (prinl "Content-Type: text/html^M") (httpCookies) (prinl "Content-Length: " (+ 59 (length N) (length X) (length B)) "^M") (prinl "^M") (prinl "<HTML>") (prinl "<HEAD><TITLE>" N " " X "</TITLE></HEAD>") (prinl "<BODY>" B "</BODY>") (prinl "</HTML>") ) ) (de noContent () (prinl "HTTP/1.0 204 No Content^M") (prinl "^M") ) (de redirect @ (httpStat 303 "See Other" (pass pack "Location: ")) ) (de forbidden () (httpStat 403 "No Permission") (throw 'http) ) (de http404 () (httpStat 404 "Not Found") ) # vi:et:ts=3:sw=3
24jun17 | admin |