/pliant/protocol/http/server.pli
1	abstract
2	[Pliant HTTP server implementation, according to RFC2616] ; eol
3	[This implementation also contains a very powerfull mecanism for dynamic pages.]
4
5
6	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
7	#
8	# This program is free software; you can redistribute it and/or
9	# modify it under the terms of the GNU General Public License version 2
10	# as published by the Free Software Foundation.
11	#
12	# This program is distributed in the hope that it will be useful,
13	# but WITHOUT ANY WARRANTY; without even the implied warranty of
14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15	# GNU General Public License for more details.
16	#
17	# You should have received a copy of the GNU General Public License
18	# version 2 along with this program; if not, write to the Free Software
19	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20
21	module "/pliant/install/minimal.pli"
22	module "/pliant/language/stream.pli"
23	module "/pliant/language/stream/openmode.pli"
24	module "/pliant/language/stream/filesystembase.pli"
25	module "/pliant/language/stream/count.pli"
26	module "chunked.pli"
27	module "/pliant/language/compiler.pli"
28	module "/pliant/language/context.pli"
29	module "/pliant/language/optimizer.pli"
30	module "/pliant/language/context.pli"
31	module "/pliant/language/os.pli"
32	module "/pliant/admin/file.pli"
33
34	submodule "/pliant/protocol/common/tcp_server.pli"
35	module "/pliant/protocol/common/misc.pli"
36	module "/pliant/protocol/common/mime.pli"
37	module "/pliant/language/schedule/resourcesem.pli"
38	module "/pliant/fullpliant/user.pli"
39	module "/pliant/fullpliant/login.pli"
40	module "site.pli"
41
42	submodule "/pliant/util/encoding/http.pli"
43	submodule "/pliant/util/encoding/html.pli"
44	module "/pliant/util/encoding/date.pli"
45	module "/pliant/util/encoding/base64.pli"
46	module "/pliant/language/type/text/str8.pli"
47	module "/pliant/language/type/text/language.pli"
48	module "/pliant/language/data/string_cast.pli"
49	module "/pliant/language/schedule/threads_engine.pli"
50	module "/pliant/admin/md5.pli"
51	module "/pliant/util/crypto/random.pli"
52	module "/pliant/util/crypto/cipher.pli"
53	module "/pliant/language/ui/ansi_terminal.pli"
54	module "/pliant/protocol/dns/name.pli"
55	module "stack.pli"
56	module "/pliant/graphic/color/rgb888.pli"
57
58	module "proxy.pli"
59	module "/pliant/fullpliant/this_computer.pli"
60
61	constant database true
62	constant compression os_zlib_filename<>""
63	constant chunking true
64	constant conservative false
65	constant common_path "/common/"+string:pliant_release_number+"/"
66	constant is_logical_computer this_computer:env:"pliant":"system":"medium"="logical"
67
68	constant http_seed_bits 128
69	constant http_rc4_laps 3
70	constant http_sign_secret_bits 256
71	constant http_cipher_secret_bits 512
72
73	constant report_load_statistics os_api="linux"
74	if report_load_statistics
75	module "/pliant/linux/kernel/statistics.pli"
76
77	(gvar TraceSlot http_trace) configure "HTTP server"
78
79	doc
80	['DynamicPage' contains all informations related to a compiled dynamic page.] ; eol
81	[Dynamic pages are compiled on the fly, the first time they are requested, and stored in the 'dynamic_pages' dictionary.]
82
83	public
84	type DynamicPage
85	field Str id
86	field Str position
87	field Str filename
88	field DateTime datetime
89	field DateTime checkedat
90	field CBool changed
91	field Link:Function function
92	field Link:Type type
93	private
94	# dynamic pages issues
95	gvar Dictionary dynamic_pages
96	gvar Sem dynamic_pages_sem
97
98
99	# styles issues
100	gvar Dictionary html_styles
101	gvar Sem html_styles_sem
102
103
104	doc
105	['HttpServer' contains the informations about the configuration of the HTTP server. The structure is built and filled when you call 'http_server' function.]
106
107	public
108	type HttpServer
109	tcp_server_fields "HTTP" 80
110	# server configuration
111	field CBool dynamic_auto_recompile <- true
112	field Float dynamic_page_recheck_delay <- 5
113	field Str log
114	# HTTP protocol configuration
115	if conservative
116	field Float protocol_level <- 1.0
117	else
118	field Float protocol_level <- 1.1
119	field CBool keep_alive_connections <- true
120	field Float keep_alive_maxi_timeout <- 120
121	field Float keep_alive_mini_timeout <- 2
122	# security issues
123	field CBool send_software_release_number <- true
124	field Int maximal_header_length <- 2^20
125	field Int maximal_form_length <- 2^20
126	field Int maximal_file_length <- 2^30
127	# statistics
128	field Intn hits_count <- 0
129	field Intn bytes_count <- 0
130	field Sem hits_sem
131
132	TcpServer maybe HttpServer
133
134
135	doc
136	['HttpRequest' contains all information about the current client HTTP request.]
137
138	public
139	type HttpRequest
140	field Link:Stream stream
141	field Link:HttpServer server
142	field Float protocol_level
143	field Str remote_ip_address
144	field CBool keep_alive_requested
145	field CBool keep_alive_applied
146	field Float keep_alive_timeout
147	#
148	field Str command
149	field Str encoded_path path
150	field Str encoded_options options
151	field Str context
152	field Link:Type context_type
153	field Str form
154	field Str user_name
155	field Int user_auth_level <- 0
156	field CBool user_is_admin <- false
157	field Str user_shaker
158	field Str browser
159	field Str browser_model ; field Float browser_release
160	field Str supported_encoding
161	field Str language
162	field Str site_name
163	field Str area_path area_root
164	field Str site_default
165	field Str style_name
166	field Str style_options
167	field Str forward
168	field Dictionary rights
169	#
170	field Str query_first_line
171	field List query_log
172	field Link:Stream query_stream
173	field CBool answer_header_sent answer_footer_sent
174	field Str answer_status           # status message that will be returned at http level
175	field DateTime answer_datetime
176	field CBool answer_is_dynamic
177	field Str answer_mime_type
178	field Int answer_size
179	field Str answer_encoding
180	field CBool answer_chunked
181	field List answer_extra
182	field Link:Stream answer_stream
183	field List temp_files
184	field TraceSession log
185	field Address log_mark
186
187	doc
188	['HtmlPage' is the status of the dynamic page that is built as an answer to the current http request.]
189
190	public
191	type HtmlPage
192	field Link:Stream http_stream
193	field Pointer:HttpRequest http_request
194	# styling
195	field TagStack tag_stack
196	field Dictionary environment
197	field Link:Function html_hook text_hook begin_hook end_hook
198	field Str button_header <- "button*0*0*"
199	# informations from the HTTP request
200	field Str file_name
201	field Str virtual_path
202	field Str options                 # decoded options
203
204
205
206
207
208	implicit site_secret_database
209	if data:sign_secret:len=0
210	data sign_secret := straight_to_Str8 (random_string http_sign_secret_bits\8) # a 256 bit secret should be enough since the MD5 signature is 128 bits
211	store
212	if data:cipher_secret:len=0
213	data cipher_secret := straight_to_Str8 (random_string http_cipher_secret_bits\8)
214	store
215	if data:sign_secret2:len=0
216	data sign_secret2 := straight_to_Str8 (random_string http_sign_secret_bits\8)
217	store
218	if data:cipher_secret2:len=0
219	data cipher_secret2 := straight_to_Str8 (random_string http_cipher_secret_bits\8)
220	store
221
222	method request generate_signature data -> sign
223	arg HttpRequest request ; arg Str data sign
224	if site_secret_database:data:sign_secret<>""
225	sign := base64_alt_encode (string_md5_binary_signature data+" "+request:user_name+" "+request:user_shaker+" "+(straight_to_Str site_secret_database:data:sign_secret))
226	else
227	sign := ""
228
229	method request check_signature data sign -> status
230	arg_rw HttpRequest request ; arg Str data sign ; arg Status status
231	if sign=(request generate_signature data)
232	status := success
233	eif site_secret_database:data:sign_secret2<>"" and sign=base64_alt_encode:(string_md5_binary_signature data+" "+request:user_name+" "+request:user_shaker+" "+(straight_to_Str site_secret_database:data:sign_secret2))
234	status := success
235	eif request:user_name<>"" and sign=base64_alt_encode:(string_md5_binary_signature data+"   "+(straight_to_Str site_secret_database:data:sign_secret))
236	status := success
237	else
238	request:log trace "invalid signature"
239	status := failure
240
241
242	method request cipher clear -> ciphered
243	arg HttpRequest request ; arg Str clear ciphered
244	ciphered := base64_alt_encode (cipher clear (straight_to_Str site_secret_database:data:cipher_secret) http_seed_bits http_rc4_laps)
245
246	method request uncipher ciphered alternate -> clear
247	arg HttpRequest request ; arg Str clear ciphered ; arg CBool alternate
248	clear := uncipher base64_alt_decode:ciphered straight_to_Str:(shunt alternate site_secret_database:data:cipher_secret2 site_secret_database:data:cipher_secret) http_seed_bits http_rc4_laps
249
250	export '. generate_signature' '. check_signature'
251	export '. cipher' '. uncipher'
252
253	method request adjust_remote_ip_address
254	arg_rw HttpRequest request
255	if is_logical_computer and request:remote_ip_address="127.0.0.1"
256	var Pointer:Arrow c :> request:query_log first
257	while c<>null
258	if ((c map Str) parse "Origin-IP:" any:(var Str rip))
259	request remote_ip_address := rip
260	c :> request:query_log next c
261
262	method request allowed name -> a
263	arg HttpRequest request ; arg Str name ; arg CBool a
264	a := request:user_is_admin or (request:rights first name)<>null and name<>""
265	# name<>"" is not really needed if user.pdb is correct, but who knows
266
267	method request what_file path -> filename
268	arg HttpRequest request ; arg Str path filename
269	filename := request:area_root+(path request:area_path:len path:len)
270
271	method request assign_rights uname ip rights
272	arg_rw HttpRequest request ; arg Str uname ip ; arg_rw Str rights
273	var Data:User u :> user uname
274	if u:style_options<>""
275	request style_options += "[lf]"+u:style_options
276	if u:language<>""
277	request language := u language
278	var Int index := language_index u:language
279	if index<>undefined
280	current_thread_header language_index := index
281	each r u:right
282	if (string request:user_auth_level)>=r:auth and (ip is_inside_ip_domain r:ip) and (r:server="" or (" "+r:server+" " search " "+computer_fullname+" " -1)<>(-1))
283	request:rights kmap r:right CBool := true
284	if r:right="administrator"
285	request user_is_admin := true
286	rights += " "+r:right
287
288	method request assign_user
289	arg_rw HttpRequest request
290	var Str ruser := request:stream safe_query "remote_user"
291	if ruser<>""
292	request user_name := ruser
293	request user_auth_level := 3
294	if compression and (request:stream safe_query "encoding")<>""
295	request supported_encoding := ""
296	request rights := var Dictionary empty_dictionary
297	var Str rights
298	if request:user_is_admin
299	rights := " administrator"
300	else
301	rights := ""
302	request assign_rights "anonymous" request:remote_ip_address rights
303	each t (user request:user_name):template
304	request assign_rights t request:remote_ip_address rights
305	if request:user_name<>""
306	request assign_rights request:user_name request:remote_ip_address rights
307	request:log trace "user " request:user_name " " request:user_auth_level " :" rights
308	if request:user_name<>""
309	if not (login_record request:user_name request:remote_ip_address (shunt request:user_is_admin "administrator" "HTTP "+(string request:user_auth_level)))
310	request user_name := ""
311	request user_auth_level := 0
312	request rights := var Dictionary empty_dictionary
313	plugin assign_user
314
315	method request try_site site -> status
316	arg_rw HttpRequest request ; arg Data:Site site ; arg Status status
317	if not exists:site
318	return failure
319	if site:computer<>computer_fullname and site:computer<>""
320	return failure
321	var Str ip := request:stream query "local_ip_address"
322	if ip<>"" and site:ip<>ip and site:ip<>""
323	return failure
324	if ((request:stream query "local_ip_port") parse (var Int port)) and site:port<>port and site:port=defined
325	return failure
326	if site:protocol<>"" and site:protocol<>"HTTP"
327	return failure
328	if site:from_ip<>"" and not (request:remote_ip_address is_inside_ip_domain site:from_ip)
329	return failure
330	var Str path := request path
331	if path:len>0 and (path path:len-1)="/"
332	path += "index.html"
333	var Str ext := path
334	ext := ext (ext search_last "/" -1)+1 ext:len
335	ext := ext (ext search_last "." ext:len) ext:len
336	request:log trace "site is " keyof:site
337	request area_path := "/"
338	request area_root := site root
339	request site_default := site default
340	request style_name := site style
341	request forward := site forward
342	var Int longuest := 0
343	var Data:SiteArea area
344	each a site:area
345	var Str p := a path
346	if (path 0 p:len)=p
347	var Int l := p len
348	if l>longuest
349	area :> a
350	longuest := l
351	eif l=longuest
352	area :> var Data:SiteArea nonexisting_area
353	if (request allowed area:read)
354	request:rights kmap "read" Bool := true
355	if (request allowed area:write)
356	request:rights kmap "write" Bool := true
357	if area:root<>""
358	p := area path
359	p := p 0 (p search_last "/" p:len)+1
360	request area_path := p
361	request area_root := area root
362	if area:style<>""
363	request style_name := area style
364	if area:style_options<>""
365	request style_options := area:style_options+"[lf]"+request:style_options
366	if site:style_options<>""
367	request style_options := site:style_options+"[lf]"+request:style_options
368	if area:forward<>""
369	request forward := area forward
370	status := success
371
372	method request assign_site
373	arg_rw HttpRequest request
374	request site_default := "/pliant/protocol/http/default.html"
375	request area_path := "/"
376	request area_root := "/"
377	part assign
378	var Str lsite := request:stream safe_query "local_site"
379	if lsite<>"" and (request:stream safe_query "remote_user")<>""
380	request site_name := lsite
381	if request:site_name<>""
382	var Data:Site rsite :> site request:site_name
383	if (request try_site rsite)=success
384	leave assign
385	var Data:NameHost logical :> name_database:data:host rsite:computer
386	if exists:logical and logical:physical=computer_fullname
387	request forward := "tcp://127.0.0.1/client/"+(string logical:http_port)
388	leave assign
389	# try proxy
390	if rsite:protocol="proxy" and (request:remote_ip_address is_inside_ip_domain rsite:from_ip)
391	if rsite:public_key<>""
392	request forward := "zchannel://"+request:site_name+"/site/80/"+computer_fullname
393	else
394	request forward := "tcp://"+request:site_name+"/client/80"
395	leave assign
396	var Str all := request site_name
397	while (all eparse any "." any:(var Str domain))
398	if site:domain:protocol="proxy" and (request:remote_ip_address is_inside_ip_domain site:domain:from_ip)
399	request forward := "tcp://"+request:site_name+"/client/80"
400	leave assign
401	all := domain
402	each s site
403	if s:ip<>"" and (request try_site s)=success
404	leave assign
405	var Str site_name := request site_name
406	if (exists name_database:data:host:site_name) and name_database:data:host:site_name:physical=computer_fullname and computer_fullname<>""
407	request forward := "tcp://127.0.0.1/client/"+(string name_database:data:host:site_name:http_port)
408	# the name was wrong, so fallback to the default site
409	if (request try_site site:computer_fullname)=success
410	request site_name := computer_fullname
411	leave assign
412	# no site is matching, so remove all granted rights
413	request rights := var Dictionary empty_dictionary
414	if request:site_name=computer_fullname or request:site_name="localhost"
415	void
416	eif http_proxy_running and (request:stream query "remote_ip_address")="127.0.0.1" and request:browser=http_proxy_browser
417	# secured proxy
418	var Pointer:Int port :> http_proxy_ports first request:site_name
419	if http_proxy_user<>"" and exists:port
420	request forward := "zchannel://"+request:site_name+"/user/"+(string port+500)+"/"+http_proxy_user+"/"+http_proxy_password
421	console "+"
422	else
423	request forward := "tcp://"+request:site_name+"/client/80"
424	console "-"
425	else
426	request:log trace "no matching site"
427	request user_is_admin := false
428	plugin assign_site
429
430
431	export '. allowed'
432
433
434
435
436
437	method p html_hook_prototype html fun
438	arg_rw HtmlPage p ; arg Str html ; arg Function fun
439	indirect
440
441	method p text_hook_prototype text fun
442	arg_rw HtmlPage p ; arg Str text ; arg Function fun
443	indirect
444	# the text must be HTML encoded
445
446	method p begin_end_hook_prototype fun
447	arg_rw HtmlPage p ; arg Function fun
448	indirect
449
450
451	method p default_html_hook text
452	arg_rw HtmlPage p ; arg Str text
453	p:http_stream writechars text
454
455	method p default_text_hook text
456	arg_rw HtmlPage p ; arg Str text
457	p:http_stream writechars text
458
459	method p default_begin_end_hook
460	arg_rw HtmlPage p
461
462
463
464
465
466	method p html html
467	arg_rw HtmlPage p ; arg Str html
468	p html_hook_prototype html p:html_hook
469
470	method p text text
471	arg_rw HtmlPage p ; arg Str text
472	p text_hook_prototype (html_encode text true) p:text_hook
473
474	export '. html' '. text'
475
476
477	method p html_encoded_text text
478	arg_rw HtmlPage p ; arg Str text
479	p text_hook_prototype text p:text_hook
480
481	function optimize_constant_text gc
482	arg_rw GeneratorContext gc
483	var Link:Instruction i :> gc first_instruction
484	while addressof:i<>null
485	var Pointer:Function f :> i function
486	if f=(the_function '. text' HtmlPage Str)
487	if i:1:where=argument_constant
488	var Link:Str encoded :> new Str (html_encode (i:1:constant map Str) true)
489	var Link:Instruction i2 :> instruction (the_function '. html_encoded_text' HtmlPage Str) i:0 (argument mapped_constant Str encoded)
490	gc insert_after_instruction i i2
491	gc remove i
492	i :> i2
493	i :> i next_instruction
494
495	record_optimizer_function optimize_constant_text "pliant optimizer rewrite instructions"
496
497
498	method p execute_style_bloc_prototype fun
499	arg_rw HtmlPage p ; arg Function fun
500	indirect
501
502	method p execute_style_setup_prototype fun
503	arg_rw HtmlPage p ; arg Function fun
504	indirect
505
506	method p execute_style_setup name -> status
507	arg_rw HtmlPage p ; arg Str name ; arg Status status
508	html_styles_sem rd_request
509	var Pointer:Arrow c :> html_styles first name
510	if c=null
511	# console "no " name " style" eol
512	html_styles_sem rd_release
513	return failure
514	# console "execute " name " style" eol
515	var Link:Function f :> c map Function
516	html_styles_sem rd_release
517	p:tag_stack initialize
518	p execute_style_setup_prototype f
519	status := success
520
521	method p execute_style_setup fun -> status
522	arg_rw HtmlPage p; arg Function fun; arg Status status
523	status := success
524	var Pointer:Arrow c:> fun:properties first "style"
525	while c<>null
526	if entry_type:c=Function
527	p execute_style_bloc_prototype (c map Function)
528	eif entry_type:c=Str
529	if (p execute_style_setup (c map Str))=failure
530	status := failure
531	c :> fun:properties next "style" c
532
533
534	function 'record style setup code' fun name
535	arg Function fun ; arg Str name
536	html_styles_sem request
537	html_styles insert name true addressof:fun
538	html_styles_sem release
539
540	named_expression style_setup_prototype
541	method page style_setup_code
542	arg_rw HtmlPage page
543	implicit page
544	body
545	'record style setup code' (the_function '. style_setup_code' HtmlPage) name
546
547	meta style_setup e
548	if e:size<>1
549	return
550	var Link:Module m :> e module
551	if (exists m:external)
552	m :> m external
553	var Link:Expression ee :> expression duplicate style_setup_prototype substitute body e:0 substitute name (expression mapped_constant m:name near e)
554	e compile_as ee
555	var Link:Expression f :> null map Expression
556	var Bool ok := track_expression style_setup_prototype "body" ee f
557	check ok
558	copy_properties f e:0
559
560
561	named_expression style_bloc_prototype
562	method page 'pliant style bloc'
563	arg_rw HtmlPage page
564	body
565
566	meta style e
567	if e:size=1 and e:0:ident="{}"
568	var Link:Expression ee :> expression duplicate style_bloc_prototype substitute body e:0 near e:0
569	ee compile
570	var Link:Function f :> (pliant_general_dictionary first ". pliant style bloc") map Function
571	if exists:f
572	e:module:properties insert "style" false addressof:f
573	pliant_general_dictionary remove ". pliant style bloc" addressof:f
574	e set_void_result
575	eif e:size=1 and (e:0 constant Str)<>null
576	var Link:Str name :> new Str ((e:0 constant Str) map Str)
577	if (name 0 1)<>"/"
578	name := (e:module:name 0 (e:module:name search_last "/" -1)+1)+name
579	e:module:properties insert "style" false addressof:name
580	e compile_as (expression immediat module:name substitute name e:0)
581
582	export style_setup 'record style setup code'
583	export style
584
585
586
587
588
589	method request http_answer line
590	arg_rw HttpRequest request ; arg Str line
591	request:stream writeline line
592	if line:len<>0
593	request:log trace "answer " line
594
595	method request send_header
596	arg_rw HttpRequest request
597	request log_mark := request:log:mark
598	if request:protocol_level<1
599	return
600	request http_answer "HTTP/"+(string request:protocol_level "fixed 1")+" "+(shunt request:answer_status<>"" request:answer_status "200 OK")
601	if request:server:send_software_release_number
602	request http_answer "Server: Pliant/"+string:pliant_release_number
603	else
604	request http_answer "Server: Pliant"
605	if request:answer_is_dynamic
606	if request:browser_model="mozilla"
607	request http_answer "Pragma: no-cache" # not supported by IE 4
608	else
609	request http_answer "Expires: 0" # not recommended in RFCs
610	eif request:answer_datetime=defined
611	request http_answer "Last-Modified: "+(rfc1123_date request:answer_datetime)
612	if request:answer_size<>undefined
613	request http_answer "Content-Length: "+(string request:answer_size)
614	if request:answer_mime_type<>""
615	request http_answer "Content-Type: "+request:answer_mime_type
616	if compression and request:answer_encoding<>""
617	request http_answer "Content-Encoding: "+request:answer_encoding
618	if request:answer_chunked
619	request http_answer "Transfer-Encoding: chunked"
620	if conservative
621	request keep_alive_applied := false
622	eif request:keep_alive_requested and (request:answer_size<>undefined or request:answer_chunked)
623	request keep_alive_applied := true
624	if request:keep_alive_applied and request:protocol_level<1.1
625	request http_answer "Connection: Keep-Alive"
626	var Pointer:Arrow c :> request:answer_extra first
627	while c<>null
628	request http_answer (c map Str)
629	c :> request:answer_extra next c
630	request http_answer ""
631	request answer_header_sent := true
632
633	method request send_header options
634	arg_rw HttpRequest request ; arg Str options
635	var Str status := options option "status" Str
636	if status<>""
637	request answer_status := status
638	var Str mime := options option "mime" Str
639	if mime<>""
640	request answer_mime_type := mime
641	var DateTime dt := options option "datetime" DateTime
642	if dt<>undefined
643	request answer_datetime := dt
644	if (options option "static")
645	request answer_is_dynamic := false
646	var Int size := options option "size" Int
647	if size<>undefined
648	request answer_size := size
649	else
650	if chunking and request:protocol_level>=1.1 and not (options option "nochunked")
651	request answer_chunked := true
652	eif (options option "keepalive")
653	request keep_alive_applied := true
654	if compression and (options option "compressed")
655	request answer_encoding := request supported_encoding
656	request send_header
657	request answer_stream :> request stream
658	if request:answer_chunked
659	var Link:Stream s :> new Stream
660	s open "chunked:" "" out+safe pliant_default_file_system request:answer_stream
661	request answer_stream :> s
662	if compression and request:answer_encoding<>""
663	var Link:Stream s :> new Stream
664	s open request:answer_encoding+":" "" out+safe pliant_default_file_system request:answer_stream
665	request answer_stream :> s
666
667	method request send_footer
668	arg_rw HttpRequest request
669	request answer_stream :> request stream
670	request answer_footer_sent := true
671	request:server:hits_sem request
672	request:server hits_count += 1
673	if request:answer_size<>undefined
674	request:server bytes_count += request answer_size
675	request:server:hits_sem release
676
677	type NullStreamDriver
678	void
679
680	StreamDriver maybe NullStreamDriver
681
682	method drv write buf mini maxi -> written
683	oarg_rw NullStreamDriver drv ; arg Address buf ; arg Int mini maxi written
684	written := maxi
685
686	method p reset_http_answer
687	arg_rw HtmlPage p
688	var Pointer:HttpRequest r :> p http_request
689	if (addressof p:http_stream)<>(addressof r:stream)
690	var Link:StreamDriver drv :> r:stream stream_driver
691	r:stream stream_driver :> new NullStreamDriver
692	p http_stream :> r stream
693	r answer_stream :> r stream
694	r:stream stream_driver :> drv
695	r answer_mime_type := ""
696	r answer_datetime := undefined
697	r answer_is_dynamic := true
698	r answer_size := undefined
699	r answer_encoding := ""
700	r answer_chunked := false
701	r keep_alive_applied := false
702	r:stream stream_write_cur := r:stream stream_write_buf
703	r:log rewind r:log_mark
704	r answer_header_sent := false
705
706
707	method p bind r
708	arg_rw HtmlPage p ; arg_rw HttpRequest r
709	p http_request :> r
710	p http_stream :> r answer_stream
711	p options := r options
712	p html_hook :> the_function '. default_html_hook' HtmlPage Str
713	p text_hook :> the_function '. default_text_hook' HtmlPage Str
714	p begin_hook :> the_function '. default_begin_end_hook' HtmlPage
715	p end_hook :> the_function '. default_begin_end_hook' HtmlPage
716	p:tag_stack mark
717	p execute_style_setup "/pliant/protocol/http/style/default.style"
718	p execute_style_setup r:style_name
719	p:tag_stack initialize
720
721	method p unbind
722	arg_rw HtmlPage p
723	p:tag_stack rewind
724
725
726	method request modified_since since -> m
727	arg HttpRequest request ; arg DateTime since ; arg CBool m
728	var Pointer:Arrow c :> request:query_log first
729	while c<>null
730	var Pointer:Str s :> c map Str
731	if (s parse word:"If-Modified-Since" ":" any:(var Str timestamp))
732	if rfc1123_date:timestamp=since
733	return false
734	c :> request:query_log next c
735	m := true
736
737
738	method request send_empty_answer status
739	arg_rw HttpRequest request ; arg Str status
740	if request:protocol_level>=1
741	request http_answer "HTTP/"+(string request:protocol_level)+" "+status
742	request http_answer ""
743
744	method request send_simple_page title header_message text_message html_message status
745	arg_rw HttpRequest request ; arg Str title header_message text_message html_message status
746	var Str a := "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2 Final//EN[dq]>[lf]"
747	a += "<html>[lf]"
748	a += "<head>[lf]"
749	if title<>""
750	a += "<title>"+html_encode:title+"</title>[lf]"
751	if header_message<>""
752	a += header_message
753	a += "</head>[lf]"
754	a += "<body>[lf]"
755	if text_message<>""
756	a += text_message
757	if html_message<>""
758	a += html_message
759	a += "</body>[lf]"
760	a += "</html>[lf]"
761	request send_header "status "+string:status+" mime [dq]text/html[dq] size "+(string a:len)
762	request:stream writechars a
763	request send_footer
764
765	method request send_redirect_answer url permanent
766	arg_rw HttpRequest request ; arg Str url ; arg CBool permanent
767	request answer_is_dynamic := not permanent
768	request:answer_extra append addressof:(new Str "Location: "+url)
769	request send_simple_page "Redirect to "+url "<script language=[dq]JavaScript[dq]>[lf]location.replace('"+url+"')[lf]</script>[lf]" "" "<p>Now computing ...</p><p><font size=[dq]-1[dq]>If your browser is not smart enough to switch automatically when the computation is over, then you'll have to select <a href=[dq]"+url+"[dq]>this link</a> to get the right page.</font></p>" (shunt permanent "301 Moved Permanently" "303 See Other")
770
771	method request send_authentification_request
772	arg_rw HttpRequest request
773	request answer_is_dynamic := true
774	# request:answer_extra append addressof:(new Str "WWW-Authenticate: Digest realm=[dq]"+request:site_name+"[dq] nonce=[dq]"+(string datetime:date)+"[dq]")
775	request:answer_extra append addressof:(new Str "WWW-Authenticate: Basic realm=[dq]"+request:site_name+"[dq]")
776	request send_simple_page "Please authenticate" "" "" "You must be logged in order to access this page." "401 Unauthorized"
777
778
779	export '. send_empty_answer' '. send_simple_page' '. send_redirect_answer' '. send_authentification_request'
780	export '. send_header' '. send_footer' '. bind' '. unbind' '. reset_http_answer'
781	export '. modified_since'
782
783
784
785	#  compile a dynamic page
786
787
788	function http_record_dynamic_page id function type
789	arg Str id ; arg Function function ; arg Type type
790	var Link:DynamicPage dp :> new DynamicPage
791	dp id := id
792	dp position := function position
793	dp filename := function:position:module_name
794	if (dp:filename parse any:(var Str realone) "(internals)")
795	dp filename := realone
796	dp datetime := (file_query dp:filename standard) datetime
797	dp checkedat := datetime
798	dp changed := false
799	dp function :> function
800	dp type :> type
801	dynamic_pages_sem request
802	if (dynamic_pages first id)=null
803	dynamic_pages insert id true addressof:dp
804	else
805	dynamic_pages first id := addressof dp
806	dynamic_pages_sem release
807	# console "recorded " id eol
808
809	export http_record_dynamic_page
810
811
812	method server find_dynamic_page filename -> dp
813	arg_rw HttpServer server ; arg Str filename ; arg Link:DynamicPage dp
814	dynamic_pages_sem rd_request
815	dp :> (dynamic_pages first filename) map DynamicPage
816	if addressof:dp<>null
817	if server:dynamic_auto_recompile and datetime:seconds-dp:checkedat:seconds>=server:dynamic_page_recheck_delay
818	var DateTime dt := (file_query dp:filename standard) datetime
819	if dt=dp:datetime
820	dp checkedat := datetime
821	else
822	dp changed := true
823	if dp:changed
824	dp :> null map DynamicPage
825	dynamic_pages_sem rd_release
826
827
828	function compile_style name
829	arg Str name
830	html_styles_sem rd_request
831	var Pointer:Arrow c :> html_styles first name
832	if c<>null
833	html_styles_sem rd_release
834	return
835	html_styles_sem rd_release
836	pliant_compiler_semaphore request
837	pliant_load_module name the_module:"/pliant/language/basic/safe.pli" 0 (null map Module)
838	pliant_compiler_semaphore release
839
840
841	method server do_compile_dynamic_page filename lines function count -> err
842	arg_rw HttpServer server ; arg Str filename ; arg List:Str lines ; arg_w Link:Function function ; arg_rw Int count ; arg Str err
843	pliant_compiler_semaphore request
844	http_trace trace "compiling page " filename
845	var Link:List program :> new List
846	var Pointer:Str eod :> lines first ; var Int linenum := 0
847	var Pointer:Str l :> lines first ; var Int n := 0 ; var CBool within_if := false
848	while exists:l
849	if (l parse word:"style" (var Str modname)) and ( (l 0 5)="style" or within_if and (l 0 7)="  style")
850	eod :> lines next l ; linenum := n+1
851	eif (l parse word:"module" (var Str modname)) and ( (l 0 6)="module" or within_if and (l 0 8)="  module")
852	eod :> lines next l ; linenum := n+1
853	if (l 0 3)="if "
854	within_if := true
855	eif (l 0 2)<>"  "
856	within_if := false
857	l :> lines next l ; n += 1
858	var Pointer:Str l :> lines first
859	while addressof:l<>addressof:eod
860	program append addressof:(new Str l)
861	l :> lines next l
862	program append addressof:(new Str "function '"+filename+"' page")
863	program append addressof:(new Str "  arg_rw HtmlPage page")
864	program append addressof:(new Str "  implicit page")
865	program append addressof:(new Str "    [0]left_zero_is_at [dq]"+filename+"[dq] "+string:linenum+" 1[0]")
866	while exists:l
867	program append addressof:(new Str "    "+l)
868	l :> lines next l
869	var Link:Module module :> new Module
870	module name := filename
871	if exists:count
872	module:properties kmap "pliant style standard button counter" Int := count
873	plugin standard_modules
874	module include the_module:"/pliant/language/basic/safe.pli"
875	module include the_module:"/pliant/language/parser/position.pli"
876	module include the_module:"/pliant/protocol/http/server.pli"
877	pliant_load_module "/pliant/protocol/http/style/default.style" the_module:"/pliant/language/basic/safe.pli" 0 (null map Module)
878	module include the_module:"/pliant/protocol/http/style/default.style"
879	plugin extra_modules
880	error_push_record (var ErrorRecord e) error_filter_all
881	compile_text program module
882	if e:id=error_id_noerror
883	function :> (pliant_general_dictionary first filename) map Function
884	check exists:function
885	pliant_general_dictionary remove filename addressof:function
886	err := ""
887	var Pointer:Arrow c :> module:properties first "style"
888	while c<>null
889	function:properties insert "style" false c
890	c :> module:properties next "style" c
891	function:properties insert "module" true addressof:module
892	else
893	function :> null map Function
894	err := e message
895	e id := error_id_noerror
896	error_pull_record e
897	if exists:count
898	count := module:properties kmap "pliant style standard button counter" Int undefined
899	module :> null map Module
900	pliant_compiler_semaphore release
901
902	method server compile_dynamic_page filename -> err
903	arg_rw HttpServer server ; arg Str filename ; arg Str err
904	(var Stream source) open filename in+safe
905	if source=failure
906	return ""
907	pliant_compiler_semaphore request
908	var Link:DynamicPage dp :> server find_dynamic_page filename
909	if exists:dp
910	pliant_compiler_semaphore release
911	return ""
912	var List:Str lines
913	while not source:atend
914	lines += source readline
915	source close
916	err := server do_compile_dynamic_page filename lines (var Link:Function function) (null map Int)
917	if exists:function
918	http_record_dynamic_page filename function (null map Type)
919	pliant_compiler_semaphore release
920
921
922	function http_precompile path
923	arg Str path
924	var Str ext := path (path search_last "." path:len) path:len
925	var Str filename := shunt ext<>".html" path (path 0 (path search_last "." path:len))+".page"
926	var Str err := (var HttpServer server) compile_dynamic_page filename
927	if err<>""
928	console "Failed to precompile dynamic page " filename " : " err eol
929
930	export http_precompile
931
932
933
934	#  send a static page
935
936
937	method request send_static_file filename options -> status
938	arg_rw HttpRequest request ; arg Str filename options ; arg Status status
939	var FileInfo info := file_query filename standard
940	if info=undefined or info:is_directory
941	return failure
942	var Str mime := options option "mime" Str
943	if mime=""
944	var Str ext := filename (filename search_last "." filename:len) filename:len
945	mime := query_mime_type ext
946	if not (request modified_since info:datetime)
947	request:answer_extra append addressof:(new Str "Date: "+rfc1123_date:datetime)
948	request send_header "status [dq]304 Not modified[dq] mime "+string:mime+" datetime "+(string info:datetime)+" static nochunked keepalive" # +" size "+(string info:size)+" static"
949	request send_footer
950	return success
951	var CBool range := true ; var Intn from := undefined ; var Intn to := undefined
952	var Pointer:Arrow c :> request:query_log first
953	while c<>null
954	var Pointer:Str s :> c map Str
955	if (s parse word:"Range" ":" word:"bytes" "=" any:(var Str sfrom) "-" any:(var Str sto))
956	sfrom parse from
957	sto parse to
958	eif (s parse word:"If-Range" ":" any:(var Str sdt))
959	if (rfc1123_date info:datetime)<>sdt
960	range := false
961	request:answer_extra append addressof:(new Str "Date: "+rfc1123_date:datetime)
962	c :> request:query_log next c
963	if from=undefined and to=undefined
964	range := false
965	if not range or from=undefined
966	from := 0
967	if not range or to=undefined
968	to := info:size-1
969	var Stream data ; data open filename in+safe+(shunt from<>0 seek 0)
970	if data=failure
971	return failure
972	if from<>0
973	if (data safe_configure "seek "+string:from)=failure
974	range := false ; from := 0 ; to := info:size-1
975	if range
976	request:answer_extra append addressof:(new Str "Content-Range: bytes "+string:from+"-"+string:to+"/"+(string info:size))
977	# request keep_alive_requested := false
978	request send_header (shunt range "status [dq]206 Partial Content[dq] " "")+" mime "+string:mime+" datetime "+(string info:datetime)+" size "+(string to-from+1)+" static"
979	part send "send static file content"
980	var Intn remain := to-from+1
981	while remain>0 and { var Int step := raw_copy data request:answer_stream 1 (cast (shunt remain<4*2^20 remain 4*2^20) Int) ; step>0 }
982	remain -= step
983	request:answer_stream flush anytime
984	data close
985	if remain<>0
986	request keep_alive_applied := false
987	request send_footer
988	status := success
989
990
991
992	#  execute and send a dynamic page
993
994
995	method page escape_html_page -> escape
996	arg_rw HtmlPage page ; arg CBool escape
997	escape := false
998	var Pointer:HttpRequest request :> page http_request
999	if request:command="POST" and request:context<>""
1000	if database
1001	# data_login request:user_name
1002	var Pointer:Str form :> request form
1003	var Int offset := 0
1004	while offset<form:len
1005	var Int stop := ((form offset form:len) search "&" form:len-offset)+offset
1006	if((form offset stop-offset) parse any:(var Str name) "=" any:(var Str value))
1007	if (http_decode:name parse "data/" any:(var Str sign) "/" any:(var Str path) )
1008	path := "/"+(replace (replace (replace path "+" " ") "(" "&#") ")" ";")
1009	value := replace http_decode:(replace value "+" " ") "[cr][lf]" "[lf]"
1010	if (request check_signature path sign)=success
1011	var Data_ data := data_root search_path path false
1012	data:base:sem request
1013	var Status status := data:interface set data addressof:value Str
1014	data:base:sem release
1015	page:http_request:log trace "database set " path " = " value " " (shunt status=success "" " FAILED")
1016	else
1017	page:http_request:log trace "rejected database set " path
1018	# FIXME (page:env kmap "default data rejected" List) append addressof:(new Str path)
1019	offset := stop+1
1020	if request:temp_files:first=null and (not (exists request:context_type) or (request:context_type:properties first "http stay")=null)
1021	page reset_http_answer
1022	request send_redirect_answer request:encoded_path+"?"+request:context false
1023	return true
1024
1025	function http_execute_dynamic_page page f
1026	arg_rw HtmlPage page ; arg Function f
1027	indirect
1028
1029	function http_execute_dynamic_sub_page buf f
1030	arg Address buf ; arg Function f
1031	indirect
1032
1033	if database
1034	module "/pliant/storage/database.pli"
1035	module "/pliant/language/data/string_cast.pli"
1036
1037
1038	method request send_dynamic_file filename virtualpath -> status
1039	arg_rw HttpRequest request ; arg Str filename virtualpath ; arg Status status
1040	later
1041
1042	method request send_misc_answer name
1043	arg_rw HttpRequest request ; arg Str name
1044	var Str path := common_path+"misc/"+name+".html"
1045	var Str filename := request site_default
1046	filename := (filename 0 (filename search_last "." filename:len))+".page"
1047	if (request send_dynamic_file filename path)=failure
1048	request send_simple_page name "" "Could not find '"+path+"' on the server." "" "404 Not Found"
1049
1050
1051	method request send_dynamic_file filename virtualpath -> status
1052	arg_rw HttpRequest request ; arg Str filename virtualpath ; arg Status status
1053	var Link:DynamicPage sp :> request:server find_dynamic_page filename
1054	if not exists:sp
1055	var Str err := request:server compile_dynamic_page filename
1056	if err<>""
1057	request send_simple_page "Bug in page "+request:path "" "There is a bug in the dynamic page "+request:path+".[lf]" "<PRE>[lf]"+(replace html_encode:err "&#10;" "[lf]")+"[lf]<PRE>[lf]" "500 Internal Server Error"
1058	return success
1059	sp :> request:server find_dynamic_page filename
1060	if not exists:sp
1061	return failure
1062	var Link:DynamicPage dp ; var Str context
1063	if ("&"+request:form+"&"+request:encoded_options+"=" eparse any "&button*" (var Int context_x) "*" (var Int context_y) "*" any:(var Str button) "*" any:(var Str scontext) "*" any:(var Str signature) "=" any)
1064	button := http_decode button
1065	context := request uncipher http_decode:scontext false
1066	signature := http_decode signature
1067	if (request check_signature button+" "+context signature)=success
1068	void
1069	eif { context := request uncipher http_decode:scontext true ; (request check_signature button+" "+context signature)=success }
1070	void
1071	else
1072	request form := "" ; request encoded_options := ""
1073	request send_misc_answer "signature"
1074	return success # wrong signature
1075	dp :> request:server find_dynamic_page http_decode:button
1076	if not exists:dp and (button parse any:(var Str modulename) ".pli/" any) and (modulename 0 1)="/"
1077	pliant_compiler_semaphore request
1078	pliant_load_module modulename+".pli" the_module:"/pliant/language/basic/safe.pli" 0 (null map Module)
1079	pliant_compiler_semaphore release
1080	dp :> request:server find_dynamic_page http_decode:button
1081	if not exists:dp and (button parse any:(var Str modulename) ".page/" any) and (modulename 0 1)="/"
1082	request:server compile_dynamic_page modulename+".page"
1083	dp :> request:server find_dynamic_page http_decode:button
1084	if not exists:dp
1085	request form := "" ; request encoded_options := ""
1086	request send_misc_answer "obsolete"
1087	return success # there is no such button
1088	else
1089	dp :> sp
1090	context := ""
1091	if default_charset_is_utf8
1092	request send_header "mime [dq]text/html; charset=UTF8[dq] datetime "+(string dp:datetime)+" compressed chunked"
1093	else
1094	request send_header "mime [dq]text/html; charset=iso-8859-1[dq] datetime "+(string dp:datetime)+" compressed chunked"
1095	(var HtmlPage page) bind request
1096	page file_name := dp filename
1097	page virtual_path := virtualpath
1098	check dp:function:nb_args=1
1099	if (dp:function arg 0):type=HtmlPage
1100	if not page:escape_html_page
1101	part execute "execute dynamic page "+filename
1102	page execute_style_setup sp:function
1103	page begin_end_hook_prototype page:begin_hook
1104	http_execute_dynamic_page page dp:function
1105	page begin_end_hook_prototype page:end_hook
1106	status := shunt request:answer_header_sent success failure
1107	eif { var Pointer:Type t :> unpointerto (dp:function arg 0):type ; exists t }
1108	var Str pc := "" ## section "copy context"
1109	var Address buf ; buf := memory_allocate t:size null
1110	t build_instance buf
1111	for (var Int i) 0 t:nb_fields-1
1112	var Pointer:TypeField tf :> t field i
1113	if tf:name="page"
1114	(buf translate Byte tf:offset) map Address := addressof page
1115	eif (tf:properties first "pliant editable")<>null and ("&"+request:form+"&" eparse any (pattern "&"+tf:name+"=") any:(var Str value) "&" any:(var Str remain))
1116	value := replace (replace value "+" " ") "%0D%0A" "%0A"
1117	var Str all := "&"+remain
1118	while (all eparse any (pattern "&"+tf:name+"=") any:(var Str extra) "&" any:(var Str remain))
1119	value += "%%0A"+(replace (replace extra "+" " ") "%0D%0A" "%0A")
1120	all := "&"+remain
1121	pc += "&"+tf:name+"="+value
1122	from_string (buf translate Byte tf:offset) tf:type http_decode:value "db"
1123	eif ("&"+context+"&" eparse any (pattern "&"+tf:name+"=") any:value "&" any)
1124	pc += "&"+tf:name+"="+value
1125	if database and tf:type:is_data
1126	(buf translate Byte tf:offset) map Data_ := data_root search_path http_decode:value false
1127	else
1128	from_string (buf translate Byte tf:offset) tf:type http_decode:value "db"
1129	var Str id := button
1130	request context_type :> t
1131	var Int pos_x := 0 ; var Int pos_y := 0
1132	var Str all := "&"+request:form+"&"
1133	while (all parse any "&_" any:(var Str variable) "=" any:(var Str value) "&" any:(var Str remain))
1134	if variable="pliant_x"
1135	value parse pos_x
1136	eif variable="pliant_y"
1137	value parse pos_y
1138	else
1139	pc += "&_"+variable+"="+value
1140	all := "&"+remain
1141	request context := "button*"+string:pos_x+"*"+string:pos_y+"*"+http_encode:id+"*"+(request cipher pc)+"*"+(request generate_signature id+" "+pc)
1142	if not page:escape_html_page
1143	request:log trace "execute "+dp:position
1144	part execute "execute dynamic page "+dp:position
1145	page execute_style_setup sp:function
1146	page begin_end_hook_prototype page:begin_hook
1147	http_execute_dynamic_sub_page buf dp:function
1148	page begin_end_hook_prototype page:end_hook
1149	t destroy_instance buf
1150	memory_free buf
1151	status := shunt request:answer_header_sent success failure
1152	else
1153	status := failure
1154	page unbind
1155	if status=success and not request:answer_footer_sent
1156	request send_footer
1157
1158
1159	method request send_dynamic_answer path -> status
1160	arg_rw HttpRequest request ; arg Str path ; arg Status status
1161	if (path (path search_last "." path:len) path:len)=".html"
1162	var Str filename := request what_file path
1163	filename := (filename 0 (filename search_last "." filename:len))+".page"
1164	if (request send_dynamic_file filename "")=success
1165	return success
1166	eif (path path:len-1)="/"
1167	var Str filename := request what_file path+"index.html"
1168	filename := (filename 0 (filename search_last "." filename:len))+".page"
1169	if (request send_dynamic_file filename "")=success
1170	return success
1171	var Str rpath := reverse path
1172	var Str virtualpath := ""
1173	while (rpath eparse any:(var Str rextra) "/" any:(var Str rbase))
1174	virtualpath := "/"+reverse:rextra+virtualpath
1175	var Str filename := request what_file reverse:rbase+"/virtual_tree.page"
1176	if (request send_dynamic_file filename virtualpath)=success
1177	return success
1178	rpath := rbase
1179	status := failure
1180
1181
1182
1183
1184	#  studying client query
1185
1186
1187	function find_browser_identity id model release
1188	arg Str id ; arg_w Str model ; arg_w Float release
1189	var Str value := lower id
1190	if (value parse word:"pliant" "/" release any)
1191	model := "pliant"
1192	eif (value parse any word:"opera" "/" release any) or (value parse any word:"opera" release any)
1193	model := "opera"
1194	eif (value parse any word:"msie" release any)
1195	model := "ie"
1196	eif (value parse any word:"konqueror" "/" release any) or (value parse any word:"safari" "/" release any)
1197	model := "konqueror"
1198	eif (value parse any word:"compatible" any)
1199	model := "" ; release := undefined
1200	eif (value parse any word:"firefox" "/" release any)
1201	model := "mozilla"
1202	eif (value parse word:"mozilla" "/" release any)
1203	if release<5
1204	model := "netscape"
1205	else
1206	model := "mozilla"
1207	release := 1
1208	else
1209	model := "" ; release := undefined
1210	plugin browser_identity
1211
1212
1213	method request browser_walkaround
1214	arg_rw HttpRequest request
1215	plugin browser_walkaround
1216
1217	method request forward target extra
1218	arg_rw HttpRequest request ; arg Str target extra
1219	plugin forward_begin
1220	var Link:Stream s :> request stream
1221	s stream_flags := s:stream_flags .or. noautopost
1222	var Link:Stream d :> new Stream
1223	d open target in+out+cr+lf+safe+noautopost
1224	if d=failure
1225	return
1226	d writeline request:query_first_line
1227	var Pointer:Arrow c :> request:query_log first
1228	while c<>null
1229	d writeline (c map Str)
1230	c :> request:query_log next c
1231	if extra:len>0
1232	d writeline extra
1233	d writeline ""
1234	d writechars request:form
1235	d flush anytime
1236	var Sem sem ; sem request
1237	thread
1238	while { d read_available (var Address adr2) (var Int size2) ; size2<>0 }
1239	s raw_write adr2 size2
1240	s flush anytime
1241	s safe_configure "shutdown"
1242	share:sem release
1243	while { s read_available (var Address adr1) (var Int size1) ; size1<>0 }
1244	d raw_write adr1 size1
1245	d flush anytime
1246	d safe_configure "shutdown"
1247	sem request ; sem release
1248	plugin forward_end
1249
1250
1251	function digest s -> h
1252	arg Str s h
1253	h := lower string_md5_hexa_signature:s
1254
1255	function unhexa s -> i
1256	arg Str s ; arg Int i
1257	i := 0
1258	for (var Int j) 0 s:len-1
1259	var Int c := s:j number
1260	if c>="0":0:number and c<="9":0:number
1261	i := i*16+(c-"0":0:number)
1262	eif c>="A":0:number and c<="F":0:number
1263	i := i*16+(c-"A":0:number+10)
1264	eif c>="a":0:number and c<="f":0:number
1265	i := i*16+(c-"a":0:number+10)
1266	eif c=" ":number
1267	void
1268	else
1269	return undefined
1270
1271
1272	method request parse_then_answer
1273	arg_rw HttpRequest request
1274	implicit request
1275	user_name := ""
1276	user_auth_level := 0
1277	user_shaker := ""
1278	user_is_admin := false
1279	site_name := ""
1280	form := ""
1281	context := ""
1282	context_type :> null map Type
1283	keep_alive_applied := false
1284	query_log := var List empty_list
1285	answer_header_sent := false
1286	answer_footer_sent := false
1287	answer_extra := var List empty_list
1288	answer_status := ""
1289	answer_mime_type := ""
1290	answer_datetime := undefined
1291	answer_is_dynamic := true
1292	answer_size := undefined
1293	answer_encoding := ""
1294	answer_chunked := false
1295	answer_stream :> request stream
1296	log_mark := request:log mark
1297	var Pointer:Stream http :> request stream
1298	part parse "parse HTTP request"
1299	var Str cmd := http readline ## section "parse_then_answer header"
1300	request query_first_line := cmd
1301	request:log trace "query " cmd
1302	var Str command protocol
1303	if (cmd eparse any:command _ (any request:encoded_path) _ any:(var Str protocol))
1304	if (request:encoded_path eparse "http://" any "/" any:(var Str remain))
1305	request encoded_path := "/"+remain
1306	if not (protocol parse word:"HTTP" "/" request:protocol_level)
1307	request send_empty_answer "400 Bad Request"
1308	return
1309	request protocol_level := min request:protocol_level request:server:protocol_level
1310	eif (cmd eparse any:command "_" (any request:encoded_path))
1311	request protocol_level := 0.9
1312	else
1313	request send_empty_answer "400 Bad Request"
1314	return
1315	request keep_alive_requested := request:protocol_level>=1.1
1316	if (request:encoded_path parse any:(var Str base) "?" (any request:encoded_options))
1317	request encoded_path := base
1318	else
1319	request encoded_options := ""
1320	request command := command
1321	request path := http_decode request:encoded_path
1322	request options := http_decode request:encoded_options
1323	var Int length := undefined
1324	var CBool chunked := false
1325	var CBool multipart := false
1326	var CBool