/http.arc

  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 (readbytes it from))
123    (when (findsubseq "x-www-form-urlencoded" (alref req!hds "Content-Type"))
124      (= req!args (join req!args (parse-args:string (map [coerce _ 'char] req!body)))))))
125
126(def start-httpd ((o port 8080))
127  (wipe stop-httpd*)
128  (prn "httpd: serving on port " port)
129  (thread:httpd-serve port))
130
131
132;; Very basic HTTP client.  still a work in progress: incomplete/ugly
133;
134; /!\ To have the code below working, you need to patch Arc to get
135; client sockets.  here the function is called 'client-socket
136
137(def parse-url (url)
138  (with (prot "http"  host nil 	port 80	 path "/")
139    (awhen (findsubseq "://" url)  ; explicit protocol?
140      (= prot (downcase:cut url 0 it)
141      	 url (cut url (+ it 3))))
142    (aif (pos #\/ url)  ; deal with host & path
143    	 (= host (cut url 0 it)
144	    path (cut url it))
145	 (= host url))
146    (awhen (pos #\: host)  ; explicit port?
147      (= port (int (cut host inc.it))
148      	 host (cut host 0 it)))
149    (list prot host port path)))
150
151(def mk-http-req (method host path (o hds) (o port 80) (o body))
152  (let (in out) (client-socket host port)
153    (w/stdout out 
154      (reqhead (upcase method) path hds)
155      (prt body)
156      (flushout))
157    (after (list (read-resp in) in)
158           (close out))))
159
160(def http-get (url)  ; consume the headers and return the output stream
161  (let (prot host port path) (parse-url url)
162    (cadr (mk-http-req 'GET host path (obj Host host 
163	   			           Connection "close") port))))
164
165
166; hard drives crash, files get lost, cool URLs don't die
167
168(let _infile infile
169  (def infile (url)
170    (if (begins (downcase url) "http://")
171    	(http-get url)
172	(_infile url)))
173)
174
175; arc> (filechars "http://www.faqs.org/rfcs/rfc2616.html")
176; arc> (load "http://hacks.catdancer.ws/json.arc")
177
178
179;; todo:
180; * http-ok+ & co: remove the "+"? "*"?
181;   not sure about "httpd" too.  at least rename 'httpd-serve to 'serve-http?
182;
183; * handle file uploads
184;
185; * deal with user@pwd in 'parse-url
186;
187; * actually wrong to use a table for httpd-hds*: it's legal to use the
188; same header twice.  normally should be not break to change to an assoc
189; list ('pr-headers would still work).  should make it.
190;
191; * maybe make it event-based or rewrite Arc to have a sane, really 
192; lightweight threading facility Ă  la Erlang