SHARE
TWEET

palsecam

a guest Feb 27th, 2010 355 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. ;;; http.arc: dealing with the HTTP protocol
  2.  
  3. (deftem http-msg
  4.   prot  nil     ; protocol  "HTTP/1.1"
  5.   hds   nil)    ; headers   (("Content-Type" "html") ("Location" "/new"))
  6.  
  7. ; A "request" is a message from the client to the server
  8.  
  9. (deftem (http-req http-msg)
  10.   meth    nil    ; method [downcased sym]    get, post
  11.   path    nil    ; path                      "/some/thing"
  12.   qs      nil    ; query string              "foo=bar&baz=42"
  13.   args    nil    ; args of the qs/form post  (("foo" "bar") ("baz" "42"))
  14.   cooks   nil)   ; sent cookies              (("sessid" "MTgY4h2"))
  15.  
  16. ; A "response" is a message from the server to the client
  17.  
  18. (deftem (http-resp http-msg)
  19.   sta     nil    ; status code   404
  20.   rea     nil)   ; reason        "Not Found"
  21.  
  22. (= http-ok+         "200 OK"
  23.    http-created+    "201 Created"
  24.    http-found+      "302 Found"
  25.    http-notmod+     "304 Not Modified"
  26.    http-bad+        "400 Bad Request"
  27.    http-forbidden+  "403 Forbidden"
  28.    http-notfound+   "404 Not Found")
  29.  
  30.  
  31. (def read-headers ((o from (stdin)))
  32.   (unless (is (peekc from) #\newline)  ; for suckers using \n instead of \r\n
  33.     (let line (readline from)
  34.       (awhen (pos #\: line)
  35.         (cons (list (normalize-hdname:cut line 0 it)
  36.                     (trim:cut line (+ it 1)))
  37.               (read-headers from))))))
  38.  
  39. (def normalize-hdname (name)  ; "content-type" -> "Content-Type"
  40.   (string:intersperse #\- (map capitalize (tokens name #\-))))
  41.  
  42. (def capitalize (word)  ; "foobar" -> "Foobar"
  43.   (+ (upcase word.0) (cut word 1)))
  44.  
  45. (def read-req ((o from (stdin)))
  46.   (withs ((m pa pro) (read-reqline from)
  47.           (rpa qs)   (tokens pa #\?)
  48.           hds        (read-headers from))
  49.     (inst 'http-req  'prot pro  'meth (sym:downcase m)
  50.                      'path rpa  'qs qs   'hds hds
  51.                      'cooks (parse-cooks hds)
  52.                      'args (only.parse-args qs))))
  53.  
  54. (def read-reqline ((o from (stdin)))  (tokens:readline from))
  55.  
  56. (def parse-args (argstr)  ; "foo=bar&baz=42" -> (("foo" "bar") ("baz" "42"))
  57.   (map [map urldecode (tokens _ #\=)] (tokens argstr #\&)))
  58.  
  59. (def parse-cooks (reqhds)
  60.   (reduce join
  61.     (map [map [tokens (trim _) #\=] (tokens _.1 #\;)]
  62.          (keep [caris _ "Cookie"] reqhds))))
  63.  
  64. (def read-resp ((o from (stdin)))
  65.   (let (pro st . reas) (tokens (readline from))
  66.     (inst 'http-resp 'prot pro  'sta (int st)
  67.                      'rea (string:intersperse " " reas)
  68.                      'hds (read-headers from))))
  69.  
  70. (def pr-headers (hds)
  71.   (each (n v) hds  (prrn n ": " v))
  72.   (prrn))
  73.  
  74. (def prrn args  ; print with \r\n at the end
  75.   (map1 disp args)
  76.   (prn #\return))
  77.  
  78. ; we call "head" the top part of an HTTP message,
  79. ; i.e: the status or request line plus the headers
  80.  
  81. (def reqhead (meth path hds)
  82.   (prrn upcase.meth " " path " HTTP/1.0")  
  83.   ; 1.0 because a 1.1 client should be able to deal with
  84.   ; "Transfert-Encoding: chunked" (and we don't, at least yet)
  85.   (pr-headers hds))
  86.  
  87. (def resphead ((o sta http-ok+) (o hds httpd-hds*))
  88.   (prrn "HTTP/1.1 " sta)
  89.   (pr-headers hds))
  90.  
  91. (def redirect (loc (o sta http-found+) (o hds httpd-hds*))
  92.   (resphead sta (copy hds 'Location loc)))
  93.  
  94.  
  95. ;; httpd: generic HTTP server.
  96. ; put it behind a reverse proxy, and code your own "framework".
  97. ; doesn't deal with logging, gzipping, slow and bad clients,
  98. ; keep-alive, limits of req/<time>: nginx can do it for us
  99.  
  100. (= httpd-hds*    (obj Server        "http.arc"
  101.                       Content-Type  "text/html"  ; set encoding in your HTML
  102.                       Connection    "closed")
  103.    stop-httpd*    nil
  104.    httpd-handler  nil)  ; ** the function your web app has to define **
  105.  
  106. (def httpd-serve ((o port 8080))
  107.   (w/socket s port
  108.     (until stop-httpd*
  109.       (let (in out ip) (socket-accept s)
  110.         (thread:handle-req in out ip)))))
  111.  
  112. (def handle-req (in out ip)
  113.   (after
  114.     (let req (read-req in)
  115.       (= req!ip ip)  ; TODO: check and use X-Real-IP
  116.       (read-body req in)
  117.       (w/stdout out (httpd-handler req)))
  118.     (close in out)))
  119.  
  120. (def read-body (req (o from (stdin)))
  121.   (awhen (aand (alref req!hds "Content-Length") (errsafe:int it))
  122.     (= req!body (readcs it from))
  123.     (when (findsubseq "x-www-form-urlencoded" (alref req!hds "Content-Type"))
  124.       (= req!args (join req!args (parse-args:string req!body))))))
  125.  
  126. (def readcs (n (o from (stdin)))  ; read n characters
  127.   (when (positive n)
  128.     (cons (readc from) (readcs (- n 1) from))))
  129.  
  130. (def start-httpd ((o port 8080))
  131.   (wipe stop-httpd*)
  132.   (prn "httpd: serving on port " port)
  133.   (thread:httpd-serve port))
  134.  
  135.  
  136. ;; Very basic HTTP client.  still a work in progress: incomplete/ugly
  137. ;
  138. ; /!\ To have the code below working, you need to patch Arc to get
  139. ; client sockets.  here the function is called 'client-socket
  140.  
  141. (def parse-url (url)
  142.   (with (prot "http"  host nil  port 80  path "/")
  143.     (awhen (findsubseq "://" url)  ; explicit protocol?
  144.       (= prot (downcase:cut url 0 it)
  145.          url (cut url (+ it 3))))
  146.     (aif (pos #\/ url)  ; deal with host & path
  147.          (= host (cut url 0 it)
  148.             path (cut url it))
  149.          (= host url))
  150.     (awhen (pos #\: host)  ; explicit port?
  151.       (= port (int (cut host inc.it))
  152.          host (cut host 0 it)))
  153.     (list prot host port path)))
  154.  
  155. (def mk-http-req (method host path (o hds) (o port 80) (o body))
  156.   (let (in out) (client-socket host port)
  157.     (w/stdout out
  158.       (reqhead (upcase method) path hds)
  159.       (prt body)
  160.       (flushout))
  161.     (after (list (read-resp in) in)
  162.            (close out))))
  163.  
  164. (def http-get (url)  ; consume the headers and return the output stream
  165.   (let (prot host port path) (parse-url url)
  166.     (cadr (mk-http-req 'GET host path (obj Host host
  167.                                            Connection "close") port))))
  168.  
  169.  
  170. ; hard drives crash, files get lost, cool URLs don't die
  171.  
  172. (let _infile infile
  173.   (def infile (url)
  174.     (if (begins (downcase url) "http://")
  175.         (http-get url)
  176.         (_infile url)))
  177. )
  178.  
  179. ; arc> (filechars "http://www.faqs.org/rfcs/rfc2616.html")
  180. ; arc> (load "http://hacks.catdancer.ws/json.arc")
  181.  
  182.  
  183. ;; todo:
  184. ; * http-ok+ & co: remove the "+"? "*"?
  185. ;   not sure about "httpd" too.  at least rename 'httpd-serve to 'serve-http?
  186. ;
  187. ; * handle file uploads
  188. ;
  189. ; * deal with user@pwd in 'parse-url
  190. ;
  191. ; * actually wrong to use a table for httpd-hds*: it's legal to use the
  192. ; same header twice.  normally should be not break to change to an assoc
  193. ; list ('pr-headers would still work).  should make it.
  194. ;
  195. ; * maybe make it event-based or rewrite Arc to have a sane, really
  196. ; lightweight threading facility à la Erlang
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top