Patch title: Release 85 bulk changes

Abstract:

File: /pliant/protocol/http/server.pli

Key:

	Removed line
	Added line

abstract [Pliant HTTP server implementation, according to RFC2616] [This implementation also contains a very powerfull mecani submodule "/pliant/util/encoding/http.pli" submodule "/pliant/util/encoding/html.pli" module "/pliant/util/encoding/date.pli" module "/pliant/util/encoding/base64.pli" module "/pliant/language/data/string_cast.pli" module "/pliant/admin/md5.pli" module "/pliant/util/crypto/random.pli" module "/pliant/util/crypto/cipher.pli" module "/pliant/language/ui/ansi_terminal.pli" module "/pliant/protocol/dns/name.pli"

module "stack.pli" module "/pliant/graphic/color/rgb888.pli"

public

type DynamicPage field Str filename position field DateTime datetime field DateTime checkedat field CBool changed field Link:Function function field Link:Type type type DynamicPage field Str filename position field DateTime datetime field DateTime checkedat field CBool changed field Link:Function function field Link:Type type

private

# dynamic pages issues gvar Dictionary dynamic_pages gvar Sem dynamic_pages_sem public type HttpServer tcp_server_fields "HTTP" 80 # server configuration field CBool dynamic_auto_recompile <- true field Float dynamic_page_recheck_delay <- 5 field Str log # HTTP protocol configuration

field Str protocol_level <- "1.0"

field Float protocol_level <- 1.1

field CBool keep_alive_connections <- true field Float keep_alive_timeout <- 120 # security issues field CBool send_software_release_number <- true field Int maximal_header_length <- 2^20 field Int maximal_form_length <- 2^20 field Int maximal_file_length <- 2^30 # configuration issues field CBool configure <- false field Str admin_user field Str admin_password field Str simulate # statistics field Intn hits_count <- 0 field Intn bytes_count <- 0 field Sem hits_sem public type HttpRequest field Link:Stream stream field Link:HttpServer server field Float protocol_level field CBool keep_alive_requested field CBool keep_alive_applyed # field Str url_path field Str url_options field Str context field Link:Type context_type field Str form field Str user_name field Int user_auth_level <- 0 field CBool user_is_admin <- false field Str user_shaker field Str browser field Str browser_model ; field Float browser_release field Str supported_encoding field Str lang field Str site_name field Str area_path area_root field Str area_mode field Str style_name field Str style_options field Str forward field Dictionary rights #

field Str query_first_line

field List query_log field CBool answered field Str answer_status # status message that field Str answer_mime_type field Str answer_encoding field Int answer_size field DateTime answer_datetime field CBool answer_is_dynamic field List answer_extra field List temp_files field List query_log field CBool answered field Str answer_status # status message that field Str answer_mime_type field Str answer_encoding field Int answer_size field DateTime answer_datetime field CBool answer_is_dynamic field List answer_extra field List temp_files

field Str put_file

field Str command

field TraceSession log field Address log_mark public type HtmlPage field Link:Stream http_stream

field Dictionary tags field Link:Function text_hook field Link:Function html_hook

field Pointer:HttpRequest http_request # styling

field HtmlStack html_stack

field Dictionary environment field Link:Function html_hook text_hook begin_hook end_hook

# informations from the HTTP request

field Str file_name field Str virtual_path field Str options # decoded options field Str file_name field Str virtual_path field Str options # decoded options

field Dictionary styles # http protocol related informations field Pointer:HttpRequest http_request field CBool read_only_mode <- false # fields reserved for styles field Int do_not_use_Int <- 0 field Arrow do_not_use_Arrow field Int you_can_use_Int <- undefined field Arrow you_can_use_Arrow field Dictionary env # you can store applic

method request assign_user arg_rw HttpRequest request var Str ruser := request:stream safe_query "remote_user" var Str ip := request:stream query "remote_ip_address" if ruser<>"" request user_name := ruser request user_auth_level := 3 if compression and (request:stream safe_query "encoding" request supported_encoding := "" request rights := var Dictionary empty_dictionary var Str rights if request:user_is_admin rights := " administrator" else rights := "" for (var Int lap) (shunt request:user_name<>"" 1 0) 0 st var Data:User u :> user (shunt lap=0 "anonymous" reque if u:style_options<>""

request style_options += " "+u:style_options

request style_options += "[lf]"+u:style_options

each r u:right if (string request:user_auth_level)>=r:auth and (ip request:rights kmap r:right CBool := true if r:right="administrator" request user_is_admin := true rights += " "+r:right request:log trace "user " request:user_name " " request:us if request:user_name<>"" if not (login_record request:user_name ip (shunt request request user_name := "" request user_auth_level := 0 request rights := var Dictionary empty_dictionary plugin assign_user method request try_site site simulate -> status arg_rw HttpRequest request ; arg Data:Site site ; arg CBoo if not exists:site return failure if not simulate if site:computer<>computer_fullname and site:computer<>" return failure var Str ip := request:stream query "local_ip_address" if ip<>"" and site:ip<>ip and site:ip<>"" return failure if ((request:stream query "local_ip_port") parse (var In return failure if site:protocol<>"" and site:protocol<>"HTTP" return failure each r u:right if (string request:user_auth_level)>=r:auth and (ip request:rights kmap r:right CBool := true if r:right="administrator" request user_is_admin := true rights += " "+r:right request:log trace "user " request:user_name " " request:us if request:user_name<>"" if not (login_record request:user_name ip (shunt request request user_name := "" request user_auth_level := 0 request rights := var Dictionary empty_dictionary plugin assign_user method request try_site site simulate -> status arg_rw HttpRequest request ; arg Data:Site site ; arg CBoo if not exists:site return failure if not simulate if site:computer<>computer_fullname and site:computer<>" return failure var Str ip := request:stream query "local_ip_address" if ip<>"" and site:ip<>ip and site:ip<>"" return failure if ((request:stream query "local_ip_port") parse (var In return failure if site:protocol<>"" and site:protocol<>"HTTP" return failure

if site:from_ip<>"" and not ((request:stream query "remote_ip_address") is_inside_ip_domain site:from_ip) return failure

var Str url_path := request url_path if url_path:len>0 and (url_path url_path:len-1)="/" url_path += "index.html" var Str ext := url_path ext := ext (ext search_last "/" -1)+1 ext:len ext := ext (ext search_last "." ext:len) ext:len request:log trace "site is " keyof:site if not (url_path parse "/common/" any) request area_path := "/" request area_root := site root if site:style<>"/pliant/protocol/http/style/default.style" request style_name := site style request forward := site forward var Int longuest := 0 var Data:SiteArea area each a site:area var Str p := a path ; var Str e := a extension if (url_path 0 p:len)=p and (e=ext or e="") var Int l := p:len+(shunt e=ext 10^9 0) if l>longuest area :> a longuest := l eif l=longuest area :> var Data:SiteArea nonexisting_area request area_mode := area mode if (request allowed area:read) request:rights kmap "read" Bool := true if (request allowed area:write) request:rights kmap "write" Bool := true if area:root<>"" p := area path p := p 0 (p search_last "/" p:len)+1 request area_path := p request area_root := area root if area:style<>"" request style_name := area style if area:style_options<>"" var Str url_path := request url_path if url_path:len>0 and (url_path url_path:len-1)="/" url_path += "index.html" var Str ext := url_path ext := ext (ext search_last "/" -1)+1 ext:len ext := ext (ext search_last "." ext:len) ext:len request:log trace "site is " keyof:site if not (url_path parse "/common/" any) request area_path := "/" request area_root := site root if site:style<>"/pliant/protocol/http/style/default.style" request style_name := site style request forward := site forward var Int longuest := 0 var Data:SiteArea area each a site:area var Str p := a path ; var Str e := a extension if (url_path 0 p:len)=p and (e=ext or e="") var Int l := p:len+(shunt e=ext 10^9 0) if l>longuest area :> a longuest := l eif l=longuest area :> var Data:SiteArea nonexisting_area request area_mode := area mode if (request allowed area:read) request:rights kmap "read" Bool := true if (request allowed area:write) request:rights kmap "write" Bool := true if area:root<>"" p := area path p := p 0 (p search_last "/" p:len)+1 request area_path := p request area_root := area root if area:style<>"" request style_name := area style if area:style_options<>""

request style_options += " "+area:style_options

request style_options := area:style_options+"[lf]"+request:style_options

if site:style_options<>"" if site:style_options<>""

request style_options += " "+site:style_options

request style_options := site:style_options+"[lf]"+request:style_options

if area:forward<>"" request forward := area forward status := success method request assign_site arg_rw HttpRequest request if (request:url_path parse "/common/" any) request area_path := "/common/" request area_root := "/pliant/protocol/http/common/" else request area_path := "/" request area_root := "/" part assign request area_mode := "" request style_name := "" request style_options := "" var Str lsite := request:stream safe_query "local_site" if lsite<>"" request site_name := lsite var CBool simulate := false if request:site_name="localhost" if request:server:configure leave assign if request:server:simulate<>"" request site_name := request:server:simulate simulate := true if request:site_name<>"" var Data:Site rsite :> site request:site_name if (request try_site rsite simulate)=success leave assign var Data:NameHost logical :> name_database:data:host r if exists:logical and logical:physical=computer_fullna request forward := "tcp://127.0.0.1/client/"+(string leave assign if area:forward<>"" request forward := area forward status := success method request assign_site arg_rw HttpRequest request if (request:url_path parse "/common/" any) request area_path := "/common/" request area_root := "/pliant/protocol/http/common/" else request area_path := "/" request area_root := "/" part assign request area_mode := "" request style_name := "" request style_options := "" var Str lsite := request:stream safe_query "local_site" if lsite<>"" request site_name := lsite var CBool simulate := false if request:site_name="localhost" if request:server:configure leave assign if request:server:simulate<>"" request site_name := request:server:simulate simulate := true if request:site_name<>"" var Data:Site rsite :> site request:site_name if (request try_site rsite simulate)=success leave assign var Data:NameHost logical :> name_database:data:host r if exists:logical and logical:physical=computer_fullna request forward := "tcp://127.0.0.1/client/"+(string leave assign

# try proxy if rsite:protocol="proxy" and ((request:stream query "remote_ip_address") is_inside_ip_domain rsite:from_ip)

if rsite:public_key<>"" request forward := "zchannel://"+request:site_name+"/site/80/"+computer_fullname else request forward := "tcp://"+request:site_name+"/client/80" leave assign var Str all := request site_name while (all eparse any "." any:(var Str domain))

if site:domain:protocol="proxy" and ((request:stream query "remote_ip_address") is_inside_ip_domain site:domain:from_ip)

request forward := "tcp://"+request:site_name+"/client/80" leave assign all := domain

each s site if s:ip<>"" and (request try_site s false)=success leave assign var Str site_name := request site_name if (exists name_database:data:host:site_name) and name_d request forward := "tcp://127.0.0.1/client/"+(string n # the name was wrong, so fallback to the default site if (request try_site site:computer_fullname false)=succe request site_name := computer_fullname leave assign # no site is matching, so remove all granted rights request rights := var Dictionary empty_dictionary if request:site_name=computer_fullname or request:site_n void eif http_proxy_running and (request:stream query "remote # secured proxy var Pointer:Int port :> http_proxy_ports first request if http_proxy_user<>"" and exists:port request forward := "zchannel://"+request:site_name+" console "+" else request forward := "tcp://"+request:site_name+"/clie console "-" else request:log trace "no matching site" request user_is_admin := false plugin assign_site

method p html_hook_prototype html fun arg_rw HtmlPage p ; arg Str html ; arg Function fun indirect

method p default_text_handler text html_encoded arg_rw HtmlPage p ; arg Str text ; arg CBool html_encoded var Str t if html_encoded t set text:characters text:len false # same a t := text else t := html_encode text true if (p:do_not_use_Int .and. 1)<>0 t := replace t " " " " p:http_stream writechars t

method p text_hook_prototype text fun

arg_rw HtmlPage p ; arg Str text ; arg Function fun indirect # the text must be HTML encoded

method p text_hook_prototype text html_encoded fun arg_rw HtmlPage p ; arg Str text ; arg CBool html_encoded

method p begin_end_hook_prototype fun arg_rw HtmlPage p ; arg Function fun

indirect indirect

method p text text

method p default_html_hook text

arg_rw HtmlPage p ; arg Str text arg_rw HtmlPage p ; arg Str text

p text_hook_prototype text false p:text_hook

p:http_stream writechars text

method p default_html_handler text

method p default_text_hook text

arg_rw HtmlPage p ; arg Str text p:http_stream writechars text arg_rw HtmlPage p ; arg Str text p:http_stream writechars text

method p html_hook_prototype text fun arg_rw HtmlPage p ; arg Str text ; arg Function fun indirect

method p default_begin_end_hook arg_rw HtmlPage p

#---------------------------------------------------------------------------

method p html html arg_rw HtmlPage p ; arg Str html p html_hook_prototype html p:html_hook method p html html arg_rw HtmlPage p ; arg Str html p html_hook_prototype html p:html_hook

export '. text' '. html'

method p text text arg_rw HtmlPage p ; arg Str text p text_hook_prototype (html_encode text true) p:text_hook

export '. html' '. text'

method p html_encoded_text text arg_rw HtmlPage p ; arg Str text method p html_encoded_text text arg_rw HtmlPage p ; arg Str text

p text_hook_prototype text true p:text_hook

p text_hook_prototype text p:text_hook

method p execute_style_setup_prototype options fun arg_rw HtmlPage p ; arg Str options ; arg Function fun

method p execute_style_bloc_prototype fun arg_rw HtmlPage p ; arg Function fun

indirect indirect

method p execute_style_setup_prototype fun arg_rw HtmlPage p ; arg Function fun indirect

method p execute_style_setup name -> status arg_rw HtmlPage p ; arg Str name ; arg Status status html_styles_sem rd_request var Pointer:Arrow c :> html_styles first name if c=null # console "no " name " style" eol html_styles_sem rd_release return failure # console "execute " name " style" eol var Link:Function f :> c map Function html_styles_sem rd_release method p execute_style_setup name -> status arg_rw HtmlPage p ; arg Str name ; arg Status status html_styles_sem rd_request var Pointer:Arrow c :> html_styles first name if c=null # console "no " name " style" eol html_styles_sem rd_release return failure # console "execute " name " style" eol var Link:Function f :> c map Function html_styles_sem rd_release

p execute_style_setup_prototype p:http_request:style_optio

p:html_stack initialize p execute_style_setup_prototype f

status := success method p execute_style_setup fun -> status arg_rw HtmlPage p; arg Function fun; arg Status status status := success var Pointer:Arrow c:> fun:properties first "style" while c<>null status := success method p execute_style_setup fun -> status arg_rw HtmlPage p; arg Function fun; arg Status status status := success var Pointer:Arrow c:> fun:properties first "style" while c<>null

if entry_type:c=Str

if entry_type:c=Function

p execute_style_bloc_prototype (c map Function) eif entry_type:c=Str

if (p execute_style_setup (c map Str))=failure status := failure c :> fun:properties next "style" c if (p execute_style_setup (c map Str))=failure status := failure c :> fun:properties next "style" c

method s search_from start pattern ifnotfound -> pos arg Str s ; arg Int start ; arg Str pattern ; arg Int ifno pos := ((s start s:len) search pattern ifnotfound.-.start) method p dynamic_tag_prototype options fun arg_rw HtmlPage p ; arg Str options ; arg Function fun indirect method p tag id options arg_rw HtmlPage p ; arg Str id options var Pointer:Arrow c :> p:tags first id if c=null p:http_stream writechars "<"+id+">[lf]" return if entry_type:c=Str var Str value := c map Str part substitute var Int i1 := value search character:251 -1 if i1>=0 var Int i2 := value search_from i1+1 character:252 - if i2>=0 var Int i3 := value search_from i2+1 character:253 if i3>=0 var Int i4 := value search_from i3+1 character:2 if i4>=0 var Int i5 := value search_from i4+1 character if i5>=0 if (value i2+1 i3-i2-1)=character:250 var CBool flag := options option (value i1 value := (value 0 i1)+(shunt flag (value i else var Str param := options option (value i1+ if param<>"" value := (value 0 i1)+(value i2+1 i3-i2- else value := (value 0 i1)+(value i4+1 i5-i4- restart substitute p:http_stream writechars value eif entry_type:c=Function p dynamic_tag_prototype options (c map Function) method p tag_style id style arg_rw HtmlPage p ; arg Str id style p:tags insert id true addressof:(new Str style) function tag_option id pre post default -> s arg Str id pre post default ; arg Str s s := character:251+id+character:252+pre+character:253+post function tag_flag id yes no -> s arg Str id yes no ; arg Str s s := character:251+id+character:252+character:250+characte

function 'record style setup code' fun name arg Function fun ; arg Str name html_styles_sem request html_styles insert name true addressof:fun html_styles_sem release named_expression style_setup_prototype function 'record style setup code' fun name arg Function fun ; arg Str name html_styles_sem request html_styles insert name true addressof:fun html_styles_sem release named_expression style_setup_prototype

method page style_setup_code options arg_rw HtmlPage page ; arg Str options

method page style_setup_code arg_rw HtmlPage page

implicit page body implicit page body

'record style setup code' (the_function '. style_setup_cod

'record style setup code' (the_function '. style_setup_code' HtmlPage) name

meta style_setup e if e:size<>1 return var Link:Module m :> e module if (exists m:external) m :> m external var Link:Expression ee :> expression duplicate style_setup e compile_as ee var Link:Expression f :> null map Expression var Bool ok := track_expression style_setup_prototype "bod check ok copy_properties f e:0 meta style_setup e if e:size<>1 return var Link:Module m :> e module if (exists m:external) m :> m external var Link:Expression ee :> expression duplicate style_setup e compile_as ee var Link:Expression f :> null map Expression var Bool ok := track_expression style_setup_prototype "bod check ok copy_properties f e:0

named_expression style_bloc_prototype method page 'pliant style bloc' arg_rw HtmlPage page body

meta style e meta style e

if e:size<>1 or (e:0 constant Str)=null return var Link:Str name :> new Str ((e:0 constant Str) map Str) if (name 0 1)<>"/" name := (e:module:name 0 (e:module:name search_last "/" e:module:properties insert "style" false addressof:name e compile_as (expression immediat module:name substitute n

if e:size=1 and e:0:ident="{}"

var Link:Expression ee :> expression duplicate style_bloc_prototype substitute body e:0 near e:0 ee compile var Link:Function f :> (pliant_general_dictionary first ". pliant style bloc") map Function if exists:f e:module:properties insert "style" false addressof:f pliant_general_dictionary remove ". pliant style bloc" addressof:f e set_void_result eif e:size=1 and (e:0 constant Str)<>null var Link:Str name :> new Str ((e:0 constant Str) map Str) if (name 0 1)<>"/" name := (e:module:name 0 (e:module:name search_last "/" -1)+1)+name e:module:properties insert "style" false addressof:name e compile_as (expression immediat module:name substitute name e:0)

export '. tag' '. tag_style' tag_option tag_flag style_setup export style '. execute_style_setup'

export style_setup 'record style setup code' export style

method request http_answer line arg_rw HttpRequest request ; arg Str line request:stream writeline line if line:len<>0 request:log trace "answer " line method request send_header arg_rw HttpRequest request request log_mark := request:log:mark if request:protocol_level<1 return

request http_answer "HTTP/"+request:server:protocol_level+

request http_answer "HTTP/"+(string request:protocol_level)+" "+(shunt request:answer_status<>"" request:answer_status "200 OK")

if request:server:send_software_release_number request http_answer "Server: Pliant/"+string:pliant_rele else request http_answer "Server: Pliant" if request:answer_is_dynamic if request:browser_model="mozilla" request http_answer "Pragma: no-cache" # not supported else request http_answer "Expires: 0" # not recommended in eif request:answer_datetime=defined request http_answer "Last-Modified: "+(rfc1123_date requ if request:answer_size=defined request http_answer "Content-Length: "+(string request:a if request:answer_mime_type<>"" request http_answer "Content-Type: "+request:answer_mime if compression and request:answer_encoding<>"" request http_answer "Content-Encoding: "+request:answer_ request keep_alive_applyed := request:keep_alive_requested if request:keep_alive_applyed request http_answer "Connection: Keep-Alive" var Pointer:Arrow c :> request:answer_extra first while c<>null request http_answer (c map Str) c :> request:answer_extra next c request http_answer "" request:server:hits_sem request request:server hits_count += 1 if request:answer_size=defined request:server bytes_count += request answer_size request:server:hits_sem release method p bind r arg_rw HtmlPage p ; arg_rw HttpRequest r p http_request :> r p http_stream :> r stream

p tags := var Dictionary empty_dictionary p text_hook :> the_function '. default_text_handler' HtmlP p html_hook :> the_function '. default_html_handler' HtmlP

p options := http_decode r:url_options

p html_hook :> the_function '. default_html_hook' HtmlPage Str p text_hook :> the_function '. default_text_hook' HtmlPage Str p begin_hook :> the_function '. default_begin_end_hook' HtmlPage p end_hook :> the_function '. default_begin_end_hook' HtmlPage

p:html_stack mark

p execute_style_setup "/pliant/protocol/http/style/default p execute_style_setup r:style_name if compression and r:answer_encoding<>"" p http_stream :> new Stream p:http_stream open r:answer_encoding+":" "" out+safe pli p execute_style_setup "/pliant/protocol/http/style/default p execute_style_setup r:style_name if compression and r:answer_encoding<>"" p http_stream :> new Stream p:http_stream open r:answer_encoding+":" "" out+safe pli

p:html_stack initialize

method p unbind r arg_rw HtmlPage p ; arg_rw HttpRequest r p:html_stack rewind

type NullStreamDriver void StreamDriver maybe NullStreamDriver method drv write buf mini maxi -> written oarg_rw NullStreamDriver drv ; arg Address buf ; arg Int mini maxi written written := maxi

method p reset_http_answer arg_rw HtmlPage p var Pointer:HttpRequest r :> p http_request method p reset_http_answer arg_rw HtmlPage p var Pointer:HttpRequest r :> p http_request

if (addressof p:http_stream)<>(addressof r:stream) var Link:StreamDriver drv :> r:stream stream_driver r:stream stream_driver :> new NullStreamDriver p http_stream :> r stream

r:stream stream_driver :> drv

r answer_encoding := "" r answer_encoding := ""

p http_stream :> r stream

r:stream stream_write_cur := r:stream stream_write_buf r:log rewind r:log_mark method request send_empty_answer status arg_rw HttpRequest request ; arg Str status if request:protocol_level>=1

request http_answer "HTTP/"+request:server:protocol_leve

request http_answer "HTTP/"+(string request:protocol_level)+" "+status

request http_answer "" method request send_simple_page title header_message text_me arg_rw HttpRequest request ; arg Str title header_message request answer_status := status request answer_mime_type := "text/html" request send_header (var HtmlPage page) bind request page html "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2 page html "<html>[lf]" page html "<head>[lf]" if title<>"" page html "<title>"+html_encode:title+"</title>[lf]" if header_message<>"" page html header_message page html "</head>[lf]" page html "<body>[lf]" if text_message<>"" request http_answer "" method request send_simple_page title header_message text_me arg_rw HttpRequest request ; arg Str title header_message request answer_status := status request answer_mime_type := "text/html" request send_header (var HtmlPage page) bind request page html "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2 page html "<html>[lf]" page html "<head>[lf]" if title<>"" page html "<title>"+html_encode:title+"</title>[lf]" if header_message<>"" page html header_message page html "</head>[lf]" page html "<body>[lf]" if text_message<>""

page html html_encode:text_message

page text text_message

if html_message<>"" page html html_message page html "</body>[lf]" page html "</html>[lf]" request send_footer if html_message<>"" page html html_message page html "</body>[lf]" page html "</html>[lf]" request send_footer

page unbind request

export '. send_empty_answer' '. send_simple_page' '. send_re

export '. send_header' '. send_footer' '. bind' '. reset_htt

export '. send_header' '. send_footer' '. bind' '. unbind' '. reset_http_answer'

export '. modified_since' method server do_compile_dynamic_page pagename physical name arg_rw HttpServer server ; arg Str pagename physical name pliant_compiler_semaphore request http_trace trace "compiling page " name http_current_pagename := pagename http_current_filename := physical http_current_datetime := (file_query physical standard) da var Link:List program :> new List var Pointer:Str eod :> lines first ; var Int linenum := 0 var Pointer:Str l :> lines first ; var Int n := 0 ; var CB while exists:l if (l parse word:"style" (var Str modname)) and ( (l 0 5 eod :> lines next l ; linenum := n+1 eif (l parse word:"module" (var Str modname)) and ( (l 0 eod :> lines next l ; linenum := n+1 if (l 0 3)="if " within_if := true eif (l 0 2)<>" " within_if := false l :> lines next l ; n += 1 var Pointer:Str l :> lines first while addressof:l<>addressof:eod program append addressof:(new Str l) l :> lines next l program append addressof:(new Str "function '"+name+"' pag program append addressof:(new Str " arg_rw HtmlPage page" program append addressof:(new Str " implicit page") program append addressof:(new Str " [0]left_zero_is_at while exists:l program append addressof:(new Str " "+l) l :> lines next l var Link:Module module :> new Module module name := name if exists:count module:properties kmap "pliant style standard button cou plugin standard_modules module include the_module:"/pliant/language/basic/safe.p module include the_module:"/pliant/language/parser/posit module include the_module:"/pliant/protocol/http/server. pliant_load_module "/pliant/protocol/http/style/default. module include the_module:"/pliant/protocol/http/style/d plugin extra_modules error_push_record (var ErrorRecord e) error_filter_all compile_text program module if e:id=error_id_noerror function :> (pliant_general_dictionary first name) map F check exists:function pliant_general_dictionary remove name addressof:function err := "" var Pointer:Arrow c :> module:properties first "style" while c<>null function:properties insert "style" false c c :> module:properties next "style" c

function:properties insert "module" true addressof:module

else function :> null map Function err := e message e id := error_id_noerror error_pull_record e if exists:count count := module:properties kmap "pliant style standard b module :> null map Module pliant_compiler_semaphore release method request send_static_file filename options -> status arg_rw HttpRequest request ; arg Str filename options ; ar var Str ext if (options parse "filter_" any:ext _ any) void eif (options parse "filter_" any:ext) void else ext := filename (filename search_last "." filename:len) var FileInfo info := file_query filename standard if info=undefined or info:is_directory return failure if not (request modified_since info:datetime) request answer_status := "304 Not modified" request answer_is_dynamic := false request send_header request send_footer return success var Stream data ; data open filename in+safe if data=failure return failure

var Str opt := options

var Str opt := options+" name "+string:filename

var Link:Function filter :> query_mime_static_filter ext if exists:filter var Str tempname := file_temporary var Stream temp ; temp open tempname out+safe if temp=failure return failure mime_filter data temp opt filter data close ; temp close info size := (file_query tempname standard) size data open tempname in+safe if data=failure file_delete tempname return failure var Str mime := opt option "mime" Str if mime="" mime := query_mime_type ext if mime="" mime := "binary/*" request answer_mime_type := mime request answer_size := info size request answer_datetime := info datetime request answer_is_dynamic := false request answer_encoding := "" request send_header part send "send static file content" var Int remain := info size while remain>0 and { var Int step := raw_copy data reque remain -= step request:stream flush anytime data close if exists:filter file_delete tempname if remain<>0 request keep_alive_applyed := false request send_footer status := success method page escape_html_page -> escape arg_rw HtmlPage page ; arg CBool escape escape := false var Pointer:HttpRequest request :> page http_request if database data_login request:user_name var Pointer:Str form :> request form var Int offset := 0 while offset<form:len var Int stop := ((form offset form:len) search "&" for if((form offset stop-offset) parse any:(var Str name) if (http_decode:name parse "data|" any:(var Str path path := replace (replace path "(" "&#") ")" ";" value := replace http_decode:value "[cr][lf]" "[lf if (request check_signature path sign)=success var Data_ data := data_root search_path path fal data:base:sem request var Status status := data:interface set data add data:base:sem release page:http_request:log trace "database set " path else page:http_request:log trace "rejected database s

(page:env kmap "default data rejected" List) app

# FIXME (page:env kmap "default data rejected" List) append addressof:(new Str path)

offset := stop+1 if request:form<>"" offset := stop+1 if request:form<>""

if request:put_file="" and request:temp_files:first=null

if request:temp_files:first=null and (not (exists request:context_type) or (request:context_type:properties first "http stay")=null)

page reset_http_answer request send_redirect_answer request:url_path+"?"+requ return true page reset_http_answer request send_redirect_answer request:url_path+"?"+requ return true

method page begin_html_page arg_rw HtmlPage page page tag "doctype" "" page tag "html" "" page tag "head" "" page tag "stylesheet" "" page tag "script" "" page tag "/head" "" page tag "body" "url "+(string page:http_request:url_path) page tag "page_top" "" method page end_html_page arg_rw HtmlPage page if not page:http_request:answered page tag "page_bottom" "" page tag "/body" "" page tag "/html" "" export '. begin_html_page' '. end_html_page'

function http_execute_dynamic_page page f arg_rw HtmlPage page ; arg Function f indirect method request send_dynamic_file filename virtualpath -> sta arg_rw HttpRequest request ; arg Str filename virtualpath var Link:DynamicPage sp :> request:server find_dynamic_pag if not exists:sp return failure var Link:DynamicPage dp ; var Str context if ("&"+request:form+"&"+request:url_options+"=" eparse an button := http_decode button var Str context := request uncipher http_decode:scontext signature := http_decode signature if (request check_signature button+" "+context signature void eif { context := request uncipher http_decode:scontext t void else request form := "" ; request url_options := "" var Str filename2 := request what_file "/misc/signatur request send_file filename2 "" return success # wrong signature dp :> request:server find_dynamic_page http_decode:butto if not exists:dp and (button parse any:(var Str modulena if modulename:len>4 and (modulename modulename:len-4 4 pliant_compiler_semaphore request pliant_load_module modulename the_module:"/pliant/la pliant_compiler_semaphore release dp :> request:server find_dynamic_page http_decode:b if not exists:dp request form := "" ; request url_options := "" var Str filename2 := request what_file "/misc/obsolete request send_file filename2 "" return success # there is no such button else dp :> sp context := "" request answer_mime_type := "text/html" request answer_datetime := dp datetime if compression request answer_encoding := request supported_encoding request send_header (var HtmlPage page) bind request

page options := http_decode request:url_options

page file_name := dp filename page virtual_path := virtualpath check dp:function:nb_args=1 if (dp:function arg 0):type=HtmlPage if not page:escape_html_page part execute "execute dynamic page "+filename page execute_style_setup sp:function page file_name := dp filename page virtual_path := virtualpath check dp:function:nb_args=1 if (dp:function arg 0):type=HtmlPage if not page:escape_html_page part execute "execute dynamic page "+filename page execute_style_setup sp:function

page begin_html_page

page begin_end_hook_prototype page:begin_hook

http_execute_dynamic_page page dp:function http_execute_dynamic_page page dp:function

page end_html_page

page begin_end_hook_prototype page:end_hook

status := success eif { var Pointer:Type t :> unpointerto (dp:function arg 0 var Str pc := "" ## section "copy context" var Address buf ; buf := memory_allocate t:size null t build_instance buf for (var Int i) 0 t:nb_fields-1 var Pointer:TypeField tf :> t field i if tf:name="page" (buf translate Byte tf:offset) map Address := addres eif (tf:properties first "pliant editable")<>null and pc += "&"+tf:name+"="+value value := replace http_decode:value "[cr][lf]" "[lf]" from_string (buf translate Byte tf:offset) tf:type v eif ("&"+context+"&" eparse any (pattern "&"+tf:name+" pc += "&"+tf:name+"="+value if database and tf:type:is_data (buf translate Byte tf:offset) map Data_ := data_r else value := replace http_decode:value "[cr][lf]" "[lf from_string (buf translate Byte tf:offset) tf:type var Str id := button request context_type :> t var Int pos_x := 0 ; var Int pos_y := 0 var Str all := "&"+request:form+"&" while (all parse any "&_" any:(var Str variable) "=" any if variable="pliant_x" value parse pos_x eif variable="pliant_y" value parse pos_y else pc += "&_"+variable+"="+value all := "&"+remain request context := "button+"+string:pos_x+"+"+string:pos if not page:escape_html_page request:log trace "execute "+dp:position part execute "execute dynamic page "+dp:position page execute_style_setup sp:function status := success eif { var Pointer:Type t :> unpointerto (dp:function arg 0 var Str pc := "" ## section "copy context" var Address buf ; buf := memory_allocate t:size null t build_instance buf for (var Int i) 0 t:nb_fields-1 var Pointer:TypeField tf :> t field i if tf:name="page" (buf translate Byte tf:offset) map Address := addres eif (tf:properties first "pliant editable")<>null and pc += "&"+tf:name+"="+value value := replace http_decode:value "[cr][lf]" "[lf]" from_string (buf translate Byte tf:offset) tf:type v eif ("&"+context+"&" eparse any (pattern "&"+tf:name+" pc += "&"+tf:name+"="+value if database and tf:type:is_data (buf translate Byte tf:offset) map Data_ := data_r else value := replace http_decode:value "[cr][lf]" "[lf from_string (buf translate Byte tf:offset) tf:type var Str id := button request context_type :> t var Int pos_x := 0 ; var Int pos_y := 0 var Str all := "&"+request:form+"&" while (all parse any "&_" any:(var Str variable) "=" any if variable="pliant_x" value parse pos_x eif variable="pliant_y" value parse pos_y else pc += "&_"+variable+"="+value all := "&"+remain request context := "button+"+string:pos_x+"+"+string:pos if not page:escape_html_page request:log trace "execute "+dp:position part execute "execute dynamic page "+dp:position page execute_style_setup sp:function

page begin_html_page

page begin_end_hook_prototype page:begin_hook

http_execute_dynamic_sub_page buf dp:function http_execute_dynamic_sub_page buf dp:function

page end_html_page

page begin_end_hook_prototype page:end_hook

t destroy_instance buf memory_free buf status := success else status := failure request send_footer t destroy_instance buf memory_free buf status := success else status := failure request send_footer

page unbind request

method request browser_walkaround arg_rw HttpRequest request if request:browser_model="opera" or request:browser_model= if request:supported_encoding="deflate" request supported_encoding := "gzip" plugin browser_walkaround

method request forward cmd arg_rw HttpRequest request ; arg Str cmd

method request forward target extra arg_rw HttpRequest request ; arg Str target extra

plugin forward_begin var Link:Stream s :> request stream var Link:Stream d :> new Stream plugin forward_begin var Link:Stream s :> request stream var Link:Stream d :> new Stream

d open request:forward in+out+safe

d open target in+out+cr+lf+safe

if d=failure return if d=failure return

d writeline cmd

d writeline request:query_first_line

var Pointer:Arrow c :> request:query_log first while c<>null d writeline (c map Str) c :> request:query_log next c var Pointer:Arrow c :> request:query_log first while c<>null d writeline (c map Str) c :> request:query_log next c

d writeline "Origin-IP: "+(s safe_query "remote_ip_address

if extra:len>0 d writeline extra

d writeline "" d flush anytime var Sem sem ; sem request thread while { d read_available (var Address adr2) (var Int siz s raw_write adr2 size2 s flush anytime s safe_configure "shutdown" share:sem release while { s read_available (var Address adr1) (var Int size1 d raw_write adr1 size1 d flush anytime d safe_configure "shutdown" sem request ; sem release plugin forward_end

function unhexa s -> i arg Str s ; arg Int i i := 0 for (var Int j) 0 s:len-1 var Int c := s:j number if c>="0":0:number and c<="9":0:number i := i*16+(c-"0":0:number) eif c>="A":0:number and c<="F":0:number i := i*16+(c-"A":0:number+10) eif c>="a":0:number and c<="f":0:number i := i*16+(c-"a":0:number+10) eif c=" ":number void else return undefined

method request read_data_string limit datas -> status arg_rw HttpRequest request ; arg Int limit ; arg_w Str datas ; arg Status status implicit request var CBool continue := false

var Int length := undefined var CBool chunked := false

var Pointer:Arrow c :> query_log first

while c<>null var Pointer:Str s :> c map Str

if (s parse acword:"expect" ":" acword:"100-continue" any) continue := true eif (s parse acword:"content-length" ":" (var Int i)) length := i eif (s parse acword:"transfer-encoding" ":" acword:"chunked" any) chunked := true c :> query_log next c datas := "" status := failure if length=undefined and not chunked return part read if protocol_level>=1.1 and continue send_empty_answer "100 Continue" if chunked datas := "" part read_chunk var Str csize := stream readline var Int step := unhexa csize if step<0 send_empty_answer "400 Incorrect chunk size" ; leave read if limit=defined and datas:len+step>limit send_empty_answer "500 Overflow" ; leave read datas resize datas:len+step stream raw_read (datas:characters translate Char datas:len-step) step var Str eoc := stream readline if step<>0 restart read_chunk else datas set (memory_allocate length addressof:datas) length true stream raw_read datas:characters datas:len status := success if status=failure stream error "Failed read HTTP client datas" method request read_data_file limit filename -> status arg_rw HttpRequest request ; arg Int limit ; arg Str filename ; arg Status status implicit request var CBool continue := false

var Int length := undefined var CBool chunked := false

var Pointer:Arrow c :> query_log first var DateTime dt := undefined

while c<>null var Pointer:Str s :> c map Str

if (s parse acword:"expect" ":" acword:"100-continue" any) continue := true eif (s parse acword:"content-length" ":" (var Int i)) length := i eif (s parse acword:"transfer-encoding" ":" acword:"chunked" any) chunked := true eif (s parse acword:"last-modified" ":" any:(var Str value)) dt := rfc1123_date value c :> query_log next c status := failure if length=undefined and not chunked return part read (var Stream data) open filename out+safe if data=failure send_empty_answer "500 Internal Server Error" ; leave read if protocol_level>=1.1 and continue send_empty_answer "100 Continue" if chunked length := 0 part read_chunk var Str csize := stream readline var Int step := unhexa csize if step<0 send_empty_answer "400 Incorrect chunk size" ; leave read if limit=defined and length+step>limit send_empty_answer "500 Overflow" ; leave read if (raw_copy stream data step step)<>step send_empty_answer "400 Broken connection" ; leave read length += step var Str eoc := stream readline if step<>0 restart read_chunk else if limit=defined and length>limit send_empty_answer "500 Overflow" ; leave read if (raw_copy stream data length length)<>length send_empty_answer "400 Broken connection" ; leave read if data:close=failure send_empty_answer "500 Internal Server Error" ; leave read if dt=defined file_configure filename "datetime "+string:dt status := success if status=failure data close file_delete filename stream error "Failed read HTTP client datas"

method request parse_then_answer arg_rw HttpRequest request implicit request user_name := "" user_auth_level := 0 user_shaker := "" user_is_admin := false site_name := "" form := "" context := "" context_type :> null map Type keep_alive_applyed := false query_log := var List empty_list answered := false answer_extra := var List empty_list answer_status := "" answer_mime_type := "" answer_size := undefined answer_datetime := undefined answer_is_dynamic := true log_mark := request:log mark var Pointer:Stream http :> request stream part parse "parse HTTP request" var Str cmd := http readline ## section "parse_then_answ method request parse_then_answer arg_rw HttpRequest request implicit request user_name := "" user_auth_level := 0 user_shaker := "" user_is_admin := false site_name := "" form := "" context := "" context_type :> null map Type keep_alive_applyed := false query_log := var List empty_list answered := false answer_extra := var List empty_list answer_status := "" answer_mime_type := "" answer_size := undefined answer_datetime := undefined answer_is_dynamic := true log_mark := request:log mark var Pointer:Stream http :> request stream part parse "parse HTTP request" var Str cmd := http readline ## section "parse_then_answ

request query_first_line := cmd

request:log trace "query " cmd var Str command protocol request:log trace "query " cmd var Str command protocol

if (cmd parse any:command _ (any request:url_path) _ any

if (cmd parse any:command _ (any request:url_path) _ any:(var Str protocol))

if (request:url_path eparse "http://" any "/" any:(var request url_path := "/"+remain if not (protocol parse word:"HTTP" "/" request:protoco request send_empty_answer "400 Bad Request" return if (request:url_path eparse "http://" any "/" any:(var request url_path := "/"+remain if not (protocol parse word:"HTTP" "/" request:protoco request send_empty_answer "400 Bad Request" return

request protocol_level := min request:protocol_level request:server:protocol_level

eif (cmd parse any:command "_" (any request:url_path)) request protocol_level := 0.9 eif cmd:len<=1 request keep_alive_applyed := true return else request send_empty_answer "400 Bad Request" return eif (cmd parse any:command "_" (any request:url_path)) request protocol_level := 0.9 eif cmd:len<=1 request keep_alive_applyed := true return else request send_empty_answer "400 Bad Request" return

if request:server:protocol_level<>"1.0" and request:prot

if request:protocol_level>=1.1

request keep_alive_requested := true else request keep_alive_requested := false if (request:url_path parse any:(var Str base) "?" (any r request url_path := base else request url_options := "" request keep_alive_requested := true else request keep_alive_requested := false if (request:url_path parse any:(var Str base) "?" (any r request url_path := base else request url_options := ""

var Int length := undefined ; var Str tag value

request command := command var Int length := undefined

var CBool multipart := false var CBool continue := false var CBool multipart := false var CBool continue := false

var DateTime dt := undefined

var Int header_length := 0 var Int header_length := 0

var Str tag value

if request:protocol_level>=1 while { var Str param := http readline ; param<>"" } header_length += param:len+16 if header_length<request:server:maximal_header_lengt request:query_log append addressof:(new Str param) request:log trace "option " param else header_length := request:server:maximal_header_len if (param parse any:tag ":" any:value) tag := lower tag if tag="host" request site_name := value 0 (value search ":" v eif tag="content-length" if not (value parse length) request send_empty_answer "400 Bad Request" ; eif tag="content-type" if (value parse acword:"multipart" any acword:"b multipart := true ; boundary := "[cr][lf]--"+b eif tag="expect" if (value parse acword:"100-continue" any) continue := true eif tag="connection" if (value parse any acword:"keep-alive" any) if request:server:keep_alive_connections request keep_alive_requested := true eif (value parse any acword:"close" any) request keep_alive_requested := false eif tag="user-agent" request browser := value find_browser_identity request:browser request:br eif tag="accept-language" request lang := value eif compression and tag="accept-encoding" request supported_encoding := shunt (value parse eif tag="authorization" if (value parse acword:"basic" any:(var Str enco var Str auth := base64_decode encoded if (auth parse any:(var Str user) ":" any:(var var Data:UserSecret u :> user_secret_databas if request:server:configure and user=request request user_name := user request user_auth_level := 1 request user_is_admin := true eif u:password_md5=string_md5_hexa_signature request user_name := user request user_auth_level := 1 request user_shaker := u shaker else sleep 1 eif false # (value parse acword:"digest" any) var Str user := value option "username=" Str console "user is: " user eol var Str password := "b" var Str realm := value option "realm=" Str console "realm is: " realm eol var Str nonce := value option "nonce=" Str console "nonce is: " nonce eol var Str uri := value option "uri=" Str var Str A1 := user+":"+realm+":"+password var Str A2 := "GET:"+uri var Str answer := digest digest:A1+":"+nonce+" console "signature for "+user+" is: " answer e var Str response := value option "response=" S if response=answer console "YES !" eol if request:protocol_level>=1 while { var Str param := http readline ; param<>"" } header_length += param:len+16 if header_length<request:server:maximal_header_lengt request:query_log append addressof:(new Str param) request:log trace "option " param else header_length := request:server:maximal_header_len if (param parse any:tag ":" any:value) tag := lower tag if tag="host" request site_name := value 0 (value search ":" v eif tag="content-length" if not (value parse length) request send_empty_answer "400 Bad Request" ; eif tag="content-type" if (value parse acword:"multipart" any acword:"b multipart := true ; boundary := "[cr][lf]--"+b eif tag="expect" if (value parse acword:"100-continue" any) continue := true eif tag="connection" if (value parse any acword:"keep-alive" any) if request:server:keep_alive_connections request keep_alive_requested := true eif (value parse any acword:"close" any) request keep_alive_requested := false eif tag="user-agent" request browser := value find_browser_identity request:browser request:br eif tag="accept-language" request lang := value eif compression and tag="accept-encoding" request supported_encoding := shunt (value parse eif tag="authorization" if (value parse acword:"basic" any:(var Str enco var Str auth := base64_decode encoded if (auth parse any:(var Str user) ":" any:(var var Data:UserSecret u :> user_secret_databas if request:server:configure and user=request request user_name := user request user_auth_level := 1 request user_is_admin := true eif u:password_md5=string_md5_hexa_signature request user_name := user request user_auth_level := 1 request user_shaker := u shaker else sleep 1 eif false # (value parse acword:"digest" any) var Str user := value option "username=" Str console "user is: " user eol var Str password := "b" var Str realm := value option "realm=" Str console "realm is: " realm eol var Str nonce := value option "nonce=" Str console "nonce is: " nonce eol var Str uri := value option "uri=" Str var Str A1 := user+":"+realm+":"+password var Str A2 := "GET:"+uri var Str answer := digest digest:A1+":"+nonce+" console "signature for "+user+" is: " answer e var Str response := value option "response=" S if response=answer console "YES !" eol

eif tag="last-modified" dt := rfc1123_date value

request browser_walkaround request assign_user ## section "parse_then_answer user" ; request assign_site ## how "" section "method assign_site" plugin answer_begin part answer "site '"+request:site_name+"' user '"+request: if request:style_name<>"" compile_style request:style_name if request:forward<>"" request browser_walkaround request assign_user ## section "parse_then_answer user" ; request assign_site ## how "" section "method assign_site" plugin answer_begin part answer "site '"+request:site_name+"' user '"+request: if request:style_name<>"" compile_style request:style_name if request:forward<>""

request forward cmd

request forward request:forward "Origin-IP: "+(request:stream query "remote_ip_address")

eif command="GET" request answer eif command="POST" ## section "parse_then_answer POST" if length=undefined or length<0 request send_empty_answer "411 Length Required" ; le eif length>(shunt multipart request:server:maximal_fil request send_empty_answer "413 Request Entity Too La if request:protocol_level>=1.1 and continue request send_empty_answer "100 Continue" if not multipart part read_form "read HTTP form" var Address buffer := null ; var Int done := 0 while done<length and not http:atend http read_available (var Address buf) (var Int s buffer := memory_resize buffer done+step null memory_copy buf (buffer translate Byte done) ste done += step if done=length request:form set buffer length true else var Str form_temp := file_temporary part read_multipart_form "read HTTP multipart form" (var Stream form) open form_temp out+safe var Int done := 0 while done<length and not http:atend http read_available (var Address buf) (var Int s form raw_write buf step done += step form close part parse_multipart_form "parse HTTP multipart form form open form_temp in+safe request form := "" var Int avail := request:server:maximal_form_lengt var Int avail2 := request:server:maximal_file_leng part multi while not form:atend var Str value var Str label := "" ; var Str filename := "" while { var Str line := form readline ; reques if not (line parse any word:"name" "=" "[dq] line parse any word:"name" "=" "[dq]" any: line parse any word:"filename" "=" "[dq]" if (label parse word:"file" _ word:"upload" _ label := label2 var Str temp := file_temporary var Str name := replace filename "\" "/" name := name (name search_last "/" -1)+1 nam value := string:temp+" remote_path "+string: request:temp_files append addressof:(new Str (var Stream data) open value out+safe var Str cache := "[cr][lf]" ; var Int drop : while cache:len<boundary:len and not form:at if cache:len=0 var Address a := memory_search form:stre if a=null a := form stream_read_stop var Int step := (cast a Int).-.(cast for data raw_write form:stream_read_cur step form stream_read_cur := a form raw_read addressof:(var Char ch) 1 ; while cache<>(boundary 0 cache:len) if drop=0 data raw_write cache:characters 1 ; av else drop -= 1 cache := cache 1 cache:len if avail2<0 request send_empty_answer "413 Request E data close request:log trace "file upload " value " -> else value := "" var Str cache := "" while not form:atend and cache:len<boundary: if cache:len=0 var Address a := memory_search form:stre if a=null a := form stream_read_stop var Int step := (cast a Int).-.(cast for (var Str temp) set form:stream_read_cur value += temp ; avail -= step form stream_read_cur := a form raw_read addressof:(var Char ch) 1 ; while cache<>(boundary 0 cache:len) (var Str temp) set cache:characters 1 fa value += temp ; avail -= 1 cache := cache 1 cache:len if avail<0 request send_empty_answer "413 Request E request form += "&"+http_encode:label+"="+http form raw_read addressof:(var Char ch) 1 form readline if ch="-" leave multi form close file_delete form_temp request:log trace "form " request:form request answer eif command="GET" request answer eif command="POST" ## section "parse_then_answer POST" if length=undefined or length<0 request send_empty_answer "411 Length Required" ; le eif length>(shunt multipart request:server:maximal_fil request send_empty_answer "413 Request Entity Too La if request:protocol_level>=1.1 and continue request send_empty_answer "100 Continue" if not multipart part read_form "read HTTP form" var Address buffer := null ; var Int done := 0 while done<length and not http:atend http read_available (var Address buf) (var Int s buffer := memory_resize buffer done+step null memory_copy buf (buffer translate Byte done) ste done += step if done=length request:form set buffer length true else var Str form_temp := file_temporary part read_multipart_form "read HTTP multipart form" (var Stream form) open form_temp out+safe var Int done := 0 while done<length and not http:atend http read_available (var Address buf) (var Int s form raw_write buf step done += step form close part parse_multipart_form "parse HTTP multipart form form open form_temp in+safe request form := "" var Int avail := request:server:maximal_form_lengt var Int avail2 := request:server:maximal_file_leng part multi while not form:atend var Str value var Str label := "" ; var Str filename := "" while { var Str line := form readline ; reques if not (line parse any word:"name" "=" "[dq] line parse any word:"name" "=" "[dq]" any: line parse any word:"filename" "=" "[dq]" if (label parse word:"file" _ word:"upload" _ label := label2 var Str temp := file_temporary var Str name := replace filename "\" "/" name := name (name search_last "/" -1)+1 nam value := string:temp+" remote_path "+string: request:temp_files append addressof:(new Str (var Stream data) open value out+safe var Str cache := "[cr][lf]" ; var Int drop : while cache:len<boundary:len and not form:at if cache:len=0 var Address a := memory_search form:stre if a=null a := form stream_read_stop var Int step := (cast a Int).-.(cast for data raw_write form:stream_read_cur step form stream_read_cur := a form raw_read addressof:(var Char ch) 1 ; while cache<>(boundary 0 cache:len) if drop=0 data raw_write cache:characters 1 ; av else drop -= 1 cache := cache 1 cache:len if avail2<0 request send_empty_answer "413 Request E data close request:log trace "file upload " value " -> else value := "" var Str cache := "" while not form:atend and cache:len<boundary: if cache:len=0 var Address a := memory_search form:stre if a=null a := form stream_read_stop var Int step := (cast a Int).-.(cast for (var Str temp) set form:stream_read_cur value += temp ; avail -= step form stream_read_cur := a form raw_read addressof:(var Char ch) 1 ; while cache<>(boundary 0 cache:len) (var Str temp) set cache:characters 1 fa value += temp ; avail -= 1 cache := cache 1 cache:len if avail<0 request send_empty_answer "413 Request E request form += "&"+http_encode:label+"="+http form raw_read addressof:(var Char ch) 1 form readline if ch="-" leave multi form close file_delete form_temp request:log trace "form " request:form request answer

eif command="PUT" or command="DELETE" if command="PUT" if length=defined and length<0 request send_empty_answer "400 Bad Request" ; leav if request:put_file="" request:put_file := file_temporary (var Stream data) open request:put_file out+mkdir+sa if data=failure request send_empty_answer "500 Internal Server Err if request:protocol_level>=1.1 and continue request send_empty_answer "100 Continue" if length=defined while length>0 and { var Int step := raw_copy http length -= step else while not http:atend http read_available (var Address adr) (var Int s data raw_write adr step data flush anytime if data=failure or (length=defined and length<>0) request send_empty_answer "500 Internal Server Err data close if dt=defined file_configure request:put_file "datetime "+string if (request allowed "write") var Str virtualpage := reverse request:url_path var Str virtualpath := "" while (virtualpage parse any:(var Str extra) "/" any virtualpath := "/"+reverse:extra+virtualpath var Str virtualfile := request what_file reverse:b if (request send_file virtualfile virtualpath)=suc leave answer virtualpage := base var Str filename2 := request what_file "/misc/not_allo request send_file filename2 "" else

else var Str virtualpage := reverse request:url_path var Str virtualpath := "" while (virtualpage parse any:(var Str extra) "/" any:(var Str base)) virtualpath := "/"+reverse:extra+virtualpath var Str virtualfile := request what_file reverse:base+"/virtual_tree.html" if (request send_file virtualfile virtualpath)=success

leave answer virtualpage := base

request send_empty_answer "501 Not Implemented" plugin answer_end method request temporary_cleanup arg_rw HttpRequest request var Pointer:Arrow c :> request:temp_files first while c<>null file_delete (c map Str) c :> request:temp_files remove c request send_empty_answer "501 Not Implemented" plugin answer_end method request temporary_cleanup arg_rw HttpRequest request var Pointer:Arrow c :> request:temp_files first while c<>null file_delete (c map Str) c :> request:temp_files remove c

if request:put_file<>"" file_delete request:put_file request:put_file := ""

method server start_checkup -> status arg_rw HttpServer server ; arg Status status

if server:protocol_level<>"1.0" and not server:keep_alive_ error "If you want to desable keep alive connections, th return failure

if server:configure server admin_user := keyboard_input "Please enter admini server admin_password := keyboard_input_password "And no else var CBool ok := false each s site ok := true each u user ok := true each h name_database:data:host ok := true if not ok console "The HTTP server is not configured yet, so you console "The right command might be:" eol console "pliant module /pliant/protocol/http/server.pl return failure status := success plugin server_start export '. temporary_cleanup' export '. send_static_file' '. execute_dynamic_page' '. do_c

export '. find_dynamic_page' export '. read_data_string' '. read_data_file' export '. forward'