/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 :> request:query_log first 
 257      while c<>null 
 258        if ((map Str) parse "Origin-IP:" any:(var Str rip)) 
 259          request remote_ip_address := rip 
 260        :> request:query_log next c 
 261   
 262  method request allowed name -> a 
 263    arg HttpRequest request ; arg Str name ; arg CBool a 
 264    := 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 :> user uname 
 274    if u:style_options<>"" 
 275      request style_options += "[lf]"+u:style_options 
 276    if u:language<>"" 
 277      request language := language 
 278      var Int index := language_index u:language 
 279      if index<>undefined 
 280        current_thread_header language_index := index 
 281    each 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 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>and (path path:len-1)="/" 
 332      path += "index.html" 
 333    var Str ext := path 
 334    ext := ext (ext search_last "/" -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 site:area 
 345      var Str := path 
 346      if (path p:len)=p 
 347        var Int := 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      := area path 
 359      := 0 (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 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    html_hook_prototype html p:html_hook 
 469   
 470  method p text text 
 471    arg_rw HtmlPage p ; arg Str text 
 472    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    text_hook_prototype text p:text_hook 
 480   
 481  function optimize_constant_text gc 
 482    arg_rw GeneratorContext gc 
 483    var Link:Instruction :> gc first_instruction 
 484    while addressof:i<>null 
 485      var Pointer:Function :> 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 i2 
 491          gc remove i 
 492          :> i2 
 493      :> 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 :> 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 :> map Function 
 516    html_styles_sem rd_release 
 517    p:tag_stack initialize 
 518    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        execute_style_bloc_prototype (map Function) 
 528      eif entry_type:c=Str 
 529        if (execute_style_setup (map Str))=failure 
 530          status := failure 
 531      :> 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 :> module 
 551    if (exists m:external) 
 552      :> 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    compile_as ee 
 555    var Link:Expression :> null map Expression 
 556    var Bool ok := track_expression style_setup_prototype "body" ee f 
 557    check ok 
 558    copy_properties 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=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 :> (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        set_void_result 
 575    eif e:size=and (e:constant Str)<>null 
 576      var Link:Str name :> new Str ((e: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      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 :> request:answer_extra first 
 627    while c<>null 
 628      request http_answer (map Str) 
 629      :> 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 :> new Stream 
 660      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 :> new Stream 
 664      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 :> 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      http_stream :> stream 
 693      answer_stream :> stream 
 694      r:stream stream_driver :> drv 
 695    answer_mime_type := "" 
 696    answer_datetime := undefined 
 697    answer_is_dynamic := true 
 698    answer_size := undefined 
 699    answer_encoding := "" 
 700    answer_chunked := false 
 701    keep_alive_applied := false 
 702    r:stream stream_write_cur := r:stream stream_write_buf 
 703    r:log rewind r:log_mark 
 704    answer_header_sent := false 
 705   
 706   
 707  method p bind r 
 708    arg_rw HtmlPage p ; arg_rw HttpRequest r 
 709    http_request :> r 
 710    http_stream :> answer_stream 
 711    options := options 
 712    html_hook :> the_function '. default_html_hook' HtmlPage Str 
 713    text_hook :> the_function '. default_text_hook' HtmlPage Str 
 714    begin_hook :> the_function '. default_begin_end_hook' HtmlPage 
 715    end_hook :> the_function '. default_begin_end_hook' HtmlPage 
 716    p:tag_stack mark 
 717    execute_style_setup "/pliant/protocol/http/style/default.style" 
 718    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 :> request:query_log first 
 729    while c<>null 
 730      var Pointer:Str :> map Str 
 731      if (parse word:"If-Modified-Since" ":" any:(var Str timestamp)) 
 732        if rfc1123_date:timestamp=since 
 733          return false 
 734      :> request:query_log next c 
 735    := 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 := "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2 Final//EN[dq]>[lf]" 
 747    += "<html>[lf]" 
 748    += "<head>[lf]" 
 749    if title<>"" 
 750      += "<title>"+html_encode:title+"</title>[lf]" 
 751    if header_message<>"" 
 752      += header_message 
 753    += "</head>[lf]" 
 754    += "<body>[lf]" 
 755    if text_message<>"" 
 756      += text_message 
 757    if html_message<>"" 
 758      += html_message 
 759    += "</body>[lf]" 
 760    += "</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 :> 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 :> lines first ; var Int := 0 ; var CBool within_if := false 
 848    while exists:l 
 849      if (parse word:"style" (var Str modname)) and ( (0 5)="style" or within_if and (0 7)="  style") 
 850        eod :> lines next l ; linenum := n+1 
 851      eif (parse word:"module" (var Str modname)) and ( (0 6)="module" or within_if and (0 8)="  module") 
 852        eod :> lines next l ; linenum := n+1 
 853      if (0 3)="if " 
 854        within_if := true 
 855      eif (0 2)<>"  " 
 856        within_if := false 
 857      :> lines next l ; += 1 
 858    var Pointer:Str :> lines first 
 859    while addressof:l<>addressof:eod 
 860      program append addressof:(new Str l) 
 861      :> 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      :> 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 :> module:properties first "style" 
 888      while c<>null 
 889        function:properties insert "style" false c 
 890        :> module:properties next "style" c 
 891      function:properties insert "module" true addressof:module   
 892    else 
 893      function :> null map Function 
 894      err := message 
 895      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 :> request:query_log first 
 953    while c<>null 
 954      var Pointer:Str :> map Str 
 955      if (parse word:"Range" ":" word:"bytes" "=" any:(var Str sfrom) "-" any:(var Str sto)) 
 956        sfrom parse from 
 957        sto parse to 
 958      eif (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      :> 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>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 :> 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      build_instance buf 
 1111      for (var Int i) t:nb_fields-1 
 1112        var Pointer:TypeField tf :> 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      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 :> request stream 
 1221    stream_flags := s:stream_flags .or. noautopost 
 1222    var Link:Stream :> new Stream 
 1223    open target in+out+cr+lf+safe+noautopost 
 1224    if d=failure 
 1225      return 
 1226    writeline request:query_first_line 
 1227    var Pointer:Arrow :> request:query_log first 
 1228    while c<>null 
 1229      writeline (map Str) 
 1230      :> request:query_log next c 
 1231    if extra:len>0 
 1232      writeline extra 
 1233    writeline "" 
 1234    writechars request:form 
 1235    flush anytime 
 1236    var Sem sem ; sem request 
 1237    thread 
 1238      while { read_available (var Address adr2) (var Int size2) ; size2<>0 } 
 1239        raw_write adr2 size2 
 1240        flush anytime 
 1241      safe_configure "shutdown" 
 1242      share:sem release 
 1243    while { read_available (var Address adr1) (var Int size1) ; size1<>0 } 
 1244      raw_write adr1 size1 
 1245      flush anytime 
 1246    safe_configure "shutdown" 
 1247    sem request ; sem release 
 1248    plugin forward_end 
 1249        
 1250   
 1251  function digest s -> h 
 1252    arg Str h 
 1253    := lower string_md5_hexa_signature:s 
 1254   
 1255  function unhexa s -> i 
 1256    arg Str s ; arg Int i 
 1257    := 0 
 1258    for (var Int j) s:len-1 
 1259      var Int := s:number 
 1260      if c>="0":0:number and c<="9":0:number 
 1261        := i*16+(c-"0":0:number) 
 1262      eif c>="A":0:number and c<="F":0:number 
 1263        := i*16+(c-"A":0:number+10) 
 1264      eif c>="a":0:number and c<="f":0:number 
 1265        := 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 continue := false 
 1327      var Int header_length := 0 
 1328      var Str tag value 
 1329      if request:protocol_level>=1 
 1330        while { var Str param := http readline ; param<>"" } 
 1331          header_length += param:len+16 
 1332          if header_length<request:server:maximal_header_length 
 1333            request:query_log append addressof:(new Str param) 
 1334            request:log trace "option " param 
 1335          if (param parse any:tag ":" any:value) 
 1336            tag := lower tag 
 1337            if tag="host" 
 1338              request site_name := value 0 (value search ":" value:len) 
 1339            eif tag="content-length" 
 1340              if not (value parse length) 
 1341                request send_empty_answer "400 Bad Request" ; return 
 1342            eif tag="transfer-encoding" and (value parse acword:"chunked" any) 
 1343              chunked := true 
 1344            eif tag="content-type" 
 1345              if (value parse acword:"multipart" any acword:"boundary" "=" any:(var Str boundary) ) 
 1346                multipart := true ; boundary := "[cr][lf]--"+boundary 
 1347            eif tag="expect" 
 1348              if (value parse acword:"100-continue" any) 
 1349                continue := true 
 1350            eif tag="connection" 
 1351              if (value parse any acword:"keep-alive" any) 
 1352                if request:server:keep_alive_connections 
 1353                  request keep_alive_requested := true 
 1354              eif (value parse any acword:"close" any) 
 1355                request keep_alive_requested := false 
 1356            eif tag="user-agent" 
 1357              request browser := value 
 1358              find_browser_identity request:browser request:browser_model request:browser_release 
 1359            eif tag="accept-language" 
 1360              value := value 0 (value search "," value:len) 
 1361              value := value 0 (value search ";" value:len) 
 1362              request language := value 
 1363              var Int index := language_index value 
 1364              if index<>undefined 
 1365                current_thread_header language_index := index 
 1366            eif compression and tag="accept-encoding" 
 1367              request supported_encoding := shunt (value parse any acword:"deflate" any) "deflate" (value parse any acword:"zlib" any) "zlib" (value parse any acword:"gzip" any) "gzip" "" 
 1368            eif tag="authorization" 
 1369              if (value parse acword:"basic" any:(var Str encoded)) 
 1370                var Str auth := base64_decode encoded 
 1371                if (auth parse any "\" any:(var Str user) ":" any:(var Str password)) or (auth parse any:(var Str user) ":" any:(var Str password)) 
 1372                  var Data:UserSecret :> user_secret_database:data:user user 
 1373                  if u:password_md5=string_md5_hexa_signature:password 
 1374                    request user_name := user 
 1375                    request user_auth_level := 1 
 1376                    request user_shaker := shaker 
 1377                  else 
 1378                    sleep 1 
 1379              eif false # (value parse acword:"digest" any) 
 1380                var Str user := value option "username=" Str 
 1381                console "user is: " user eol 
 1382                var Str password := "b" 
 1383                var Str realm := value option "realm=" Str 
 1384                console "realm is: " realm eol 
 1385                var Str nonce := value option "nonce=" Str 
 1386                console "nonce is: " nonce eol 
 1387                var Str uri := value option "uri=" Str 
 1388                var Str A1 := user+":"+realm+":"+password 
 1389                var Str A2 := "GET:"+uri 
 1390                var Str answer := digest digest:A1+":"+nonce+":"+digest:A2 
 1391                console "signature for "+user+" is: " answer eol 
 1392                var Str response := value option "response=" Str 
 1393                if response=answer 
 1394                  console "YES !" eol 
 1395    request browser_walkaround 
 1396    request adjust_remote_ip_address 
 1397    request style_name := "" 
 1398    request style_options := "" 
 1399    request assign_user ## section "parse_then_answer user" ; how "" section "method assign_user" 
 1400    request assign_site ## how "" section "method assign_site" 
 1401    if request:forward<>"" 
 1402      request forward request:forward "Origin-IP: "+(request:stream query "remote_ip_address") 
 1403      return 
 1404    if continue 
 1405      request send_empty_answer "100 Continue" 
 1406    request:query_stream :> new Stream 
 1407    if length<>undefined 
 1408      request:query_stream open "count:" "size "+string:length in+safe pliant_default_file_system request:stream 
 1409    eif chunked 
 1410      request:query_stream open "chunked:" "" in+safe pliant_default_file_system request:stream 
 1411    else 
 1412      request:query_stream open "count:" "size 0" in+safe pliant_default_file_system request:stream 
 1413    if database 
 1414      data_login request:user_name 
 1415    plugin answer_begin 
 1416    part answer "site '"+request:site_name+"' user '"+request:user_name+"' command "+cmd 
 1417      if not (request allowed "read"and not (report_load_statistics and command="REPORT_LOAD_STATISTICS" and (request:stream query "remote_ip_address")="127.0.0.1") 
 1418        if request:user_name="" 
 1419          request send_authentification_request 
 1420        else 
 1421          request send_misc_answer "not_allowed" 
 1422          request:log trace "requested a not allowed page " request:encoded_path 
 1423        leave answer 
 1424      if request:style_name<>"" 
 1425        compile_style request:style_name 
 1426      if command="GET" 
 1427        if query_mime_type:(request:path (request:path search_last "." request:path:len) request:path:len)<>"" 
 1428          if (request send_static_file (request what_file request:path) "")=success 
 1429            leave answer 
 1430        if (request send_dynamic_answer request:path)=success 
 1431          leave answer 
 1432        if (request:path request:path:len-1)<>"/" 
 1433          var FileInfo info := file_query (request what_file request:path+"/") standard 
 1434          if info=defined and info:is_directory and request:protocol_level>=1 
 1435            request send_redirect_answer "http://"+(shunt request:site_name<>"" request:site_name (request:stream query "local_ip_address"))+request:encoded_path+"/" true 
 1436            leave answer 
 1437        var Str filename := request site_default 
 1438        filename := (filename 0 (filename search_last "." filename:len))+".page" 
 1439        if (request send_dynamic_file filename request:path)=failure 
 1440          request:log trace "requested an unknown page " request:encoded_path 
 1441          request send_simple_page "Not found" "" "The requested page does not exist on this server." "" "404 Not Found" 
 1442      eif command="POST" ## section "parse_then_answer POST" 
 1443        if not multipart 
 1444          part read_form "read HTTP form" 
 1445            var Address buffer := null ; var Int done := 0 
 1446            while not request:query_stream:atend and done<request:server:maximal_form_length 
 1447              request:query_stream read_available (var Address adr) (var Int size) 
 1448              buffer := memory_resize buffer done+size null 
 1449              memory_copy adr (buffer translate Byte done) size 
 1450              done += size 
 1451            request:form set buffer done true 
 1452        else 
 1453          part parse_multipart_form "parse HTTP multipart form" 
 1454            request form := "" 
 1455            var Int avail := request:server:maximal_form_length 
 1456            var Int avail2 := request:server:maximal_file_length 
 1457            part multi 
 1458              while not request:query_stream:atend 
 1459                var Str value 
 1460                var Str label := "" ; var Str filename := "" 
 1461                while { var Str line := request:query_stream readline ; request:log trace "multipart_form " line ; line<>"" } 
 1462                  if not (line parse any word:"name" "=" "[dq]" any:label "[dq]" ";" word:"filename" "=" "[dq]" any:filename "[dq]" any) 
 1463                    line parse any word:"name" "=" "[dq]" any:label "[dq]" any 
 1464                    line parse any word:"filename" "=" "[dq]" any:filename "[dq]" any 
 1465                if (label parse word:"file" _ word:"upload" _ any:(var Str label2)) 
 1466                  label := label2 
 1467                  var Str temp := file_temporary 
 1468                  var Str name := replace filename "\" "/" 
 1469                  name := name (name search_last "/" -1)+name:len 
 1470                  value := string:temp+" remote_path "+string:filename+" remote_name "+string:name 
 1471                  request:temp_files append addressof:(new Str value) 
 1472                  (var Stream data) open value out+safe 
 1473                  var Str cache := "[cr][lf]" ; var Int drop := 2 
 1474                  while cache:len<boundary:len and not request:query_stream:atend 
 1475                    if cache:len=0 
 1476                      var Address := memory_search request:query_stream:stream_read_cur (cast request:query_stream:stream_read_stop Int).-.(cast request:query_stream:stream_read_cur Int) boundary:characters 1 
 1477                      if a=null 
 1478                        := request:query_stream stream_read_stop 
 1479                      var Int step := (cast Int).-.(cast request:query_stream:stream_read_cur Int) 
 1480                      data raw_write request:query_stream:stream_read_cur step ; avail2 -= step 
 1481                      request:query_stream stream_read_cur := a 
 1482                    request:query_stream raw_read addressof:(var Char ch) 1 ; cache += ch 
 1483                    while cache<>(boundary cache:len) 
 1484                      if drop=0 
 1485                        data raw_write cache:characters 1 ; avail2 -= 1 
 1486                      else 
 1487                        drop -= 1 
 1488                      cache := cache cache:len 
 1489                    if avail2<0 
 1490                      request send_empty_answer "413 Request Entity Too Large" ; leave answer 
 1491                  data close 
 1492                  request:log trace "file upload " value " -> " (file_query temp standard):size " bytes" 
 1493                else 
 1494                  value := "" 
 1495                  var Str cache := "" 
 1496                  while not request:query_stream:atend and cache:len<boundary:len 
 1497                    if cache:len=0 
 1498                      var Address := memory_search request:query_stream:stream_read_cur (cast request:query_stream:stream_read_stop Int).-.(cast request:query_stream:stream_read_cur Int) boundary:characters 1 
 1499                      if a=null 
 1500                        := request:query_stream stream_read_stop 
 1501                      var Int step := (cast Int).-.(cast request:query_stream:stream_read_cur Int) 
 1502                      (var Str temp) set request:query_stream:stream_read_cur step false 
 1503                      value += temp ; avail -= step 
 1504                      request:query_stream stream_read_cur := a 
 1505                    request:query_stream raw_read addressof:(var Char ch) 1 ; cache += ch 
 1506                    while cache<>(boundary cache:len) 
 1507                      (var Str temp) set cache:characters false 
 1508                      value += temp ; avail -= 1 
 1509                      cache := cache cache:len 
 1510                    if avail<0 
 1511                      request send_empty_answer "413 Request Entity Too Large" ; leave answer 
 1512                request form += "&"+http_encode:label+"="+http_encode:value 
 1513                request:query_stream raw_read addressof:(var Char ch) 1 
 1514                request:query_stream readline 
 1515                if ch="-" 
 1516                  leave multi 
 1517        request:log trace "form " request:form 
 1518        request send_dynamic_answer request:path 
 1519      eif report_load_statistics and command="REPORT_LOAD_STATISTICS" and (request:stream query "remote_ip_address")="127.0.0.1" 
 1520        var Str all := request path 
 1521        var Str answer := "" 
 1522        while all<>"" 
 1523          if (all parse "cpu" (var Float seconds) any:(var Str remain)) 
 1524            answer += " cpu "+string:seconds+" "+(string cpu_statistics:seconds) 
 1525          eif (all parse "interrupts" (var Float seconds) any:(var Str remain)) 
 1526            answer += " interrupts "+string:seconds+" "+(string interrupts_statistics:seconds) 
 1527          eif (all parse "net" (var Str device) (var Float seconds) any:(var Str remain)) 
 1528            net_statistics device seconds (var Float in_bps) (var Float out_bps) 
 1529            answer += " net "+string:device+" "+string:seconds+" "+string:in_bps+" "+string:out_bps 
 1530          eif (all parse "disk" (var Str device) (var Float seconds) any:(var Str remain)) 
 1531            disk_statistics device seconds (var Float read_bps) (var Float write_bps) 
 1532            answer += " disk "+string:device+" "+string:seconds+" "+string:read_bps+" "+string:write_bps 
 1533          eif (all parse "trouble" any:(var Str remain)) 
 1534            var CBool raid_alarm := false 
 1535            (var Stream proc) open "file:/proc/mdstat" in+safe 
 1536            while not proc:atend 
 1537              var Str := proc readline 
 1538              if (reverse:parse any "[rb]" any:(var Str disks) "[lb]" "[rb]" any "/" any "[lb]" any) 
 1539                if disks<>(repeat disks:len "U") 
 1540                  raid_alarm := true 
 1541            var CBool filesystem_alarm := false 
 1542            (var Stream proc) open "file:/proc/mounts" in+safe 
 1543            while not proc:atend 
 1544              var Str := proc readline 
 1545              if (parse any _ any _ any:(var Str fs) _ any:(var Str mode) _ any) 
 1546                if (","+mode+"," search ",ro," -1)<>(-1) and (fs parse "ext" any) 
 1547                  filesystem_alarm := true 
 1548            proc close 
 1549            answer += " trouble "+string:(shunt filesystem_alarm "Disk alarm" raid_alarm "RAID alarm" "") 
 1550          else 
 1551            remain := "" 
 1552          all := remain 
 1553        request send_empty_answer "200"+answer 
 1554      else 
 1555        var Str virtualpage := reverse request:path 
 1556        var Str virtualpath := "" 
 1557        while (virtualpage eparse any:(var Str extra) "/" any:(var Str base)) 
 1558          virtualpath := "/"+reverse:extra+virtualpath 
 1559          var Str virtualfile := request what_file reverse:base+"/virtual_tree.page" 
 1560          if (request send_dynamic_file virtualfile virtualpath)=success 
 1561            leave answer 
 1562          virtualpage := base 
 1563        request send_empty_answer "501 Not Implemented" 
 1564    if database 
 1565      data_logout 
 1566    plugin answer_end 
 1567   
 1568   
 1569  method request temporary_cleanup 
 1570    arg_rw HttpRequest request 
 1571    var Pointer:Arrow :> request:temp_files first 
 1572    while c<>null 
 1573      file_delete (map Str) 
 1574      :> request:temp_files remove c 
 1575   
 1576  method server service http 
 1577    arg_rw HttpServer server ; arg_rw Stream http 
 1578    http line_limit := server maximal_header_length 
 1579    var HttpRequest request 
 1580    request server :> server 
 1581    request remote_ip_address := http query "remote_ip_address" 
 1582    tcp_resource query (var Int current) (var Int maxi) 
 1583    request keep_alive_timeout := max server:keep_alive_maxi_timeout*(maxi-current)/maxi server:keep_alive_mini_timeout 
 1584    request:log bind http_trace 
 1585    var Str id := generate_id 
 1586    request:log trace "connection "+id+" start at " datetime " from " request:remote_ip_address 
 1587    request stream :> http 
 1588    var CBool first := true 
 1589    part one_request 
 1590      if http=failure 
 1591        leave one_request 
 1592      var CBool ae 
 1593      part wait "wait for "+(shunt first "first" "next")+" HTTP request beginning" 
 1594        if first 
 1595          ae := http atend 
 1596        else 
 1597          http safe_configure "timeout "+(string request:keep_alive_timeout) 
 1598          ae := http atend 
 1599          http safe_configure "timeout ?" 
 1600      if ae 
 1601        leave one_request 
 1602      if not first 
 1603        request:log trace "connection "+id+" restart at " datetime " from " request:remote_ip_address 
 1604      request parse_then_answer 
 1605      request:log flush 
 1606      if request:keep_alive_applied 
 1607        http flush async 
 1608        http safe_configure "timeout "+(string request:keep_alive_timeout) 
 1609        while not request:query_stream:atend 
 1610          request:query_stream read_available (var Address adr) (var Int size) 
 1611        first := false 
 1612        restart one_request 
 1613    request temporary_cleanup 
 1614    request:log trace "connection "+id+" stop at " datetime " from " request:remote_ip_address 
 1615   
 1616   
 1617  define_tcp_server HttpServer http_server 
 1618  export http_server 
 1619   
 1620   
 1621 
 
 1622  #  HTML pages definition functions 
 1623   
 1624   
 1625  method page execute_dynamic_page path -> status 
 1626    arg_rw HtmlPage page ; arg Str path ; arg ExtendedStatus status 
 1627    var Pointer:HttpRequest request :> page:http_request 
 1628    var Pointer:HttpServer server :> request:server 
 1629    var Str path2 filename 
 1630    if (path 0 1)<>"/" and (path search ":" -1)=(-1) 
 1631      path2 := (request:path 0 (request:path search_last "/" -1)+1)+path 
 1632    else 
 1633      path2 := path 
 1634    if (path2 eparse "pliant:" any:(var Str remain)) 
 1635      filename := remain 
 1636    eif (path2 search ":" -1)<>(-1) 
 1637      filename := path2 
 1638    else 
 1639      filename := request what_file path2 
 1640    var Str ext := filename (filename search_last "." filename:len) filename:len 
 1641    if ext=".html" 
 1642      filename := (filename 0 (filename search_last "." filename:len))+".page" 
 1643    var Link:DynamicPage dp :> server find_dynamic_page filename 
 1644    if not exists:dp 
 1645      var Str err := server compile_dynamic_page filename 
 1646      if err="" 
 1647        dp :> server find_dynamic_page filename 
 1648    var Str rpath := reverse path2 
 1649    var Str virtualpath := "" 
 1650    while not exists:dp and (rpath eparse any:(var Str rextra) "/" any:(var Str rbase)) 
 1651      virtualpath := "/"+reverse:rextra+virtualpath 
 1652      var Str filename := request what_file reverse:rbase+"/virtual_tree.page" 
 1653      var Link:DynamicPage dp :> server find_dynamic_page filename 
 1654      if not exists:dp 
 1655        if (server compile_dynamic_page filename)="" 
 1656          dp :> server find_dynamic_page filename 
 1657      rpath := rbase 
 1658    if not exists:dp or dp:function:nb_args<>or (dp:function arg 0):type<>HtmlPage 
 1659      return failure:err 
 1660    # var Str memo_path := request path ; request path := path 
 1661    var Str memo_file_name := page file_name ; page file_name := filename 
 1662    var Str memo_virtual_path := page virtual_path ; page virtual_path := virtualpath 
 1663    page execute_style_setup dp:function 
 1664    http_execute_dynamic_page page dp:function 
 1665    # request path := memo_path 
 1666    page file_name := memo_file_name 
 1667    page virtual_path := memo_virtual_path 
 1668    status := success 
 1669   
 1670  export '. temporary_cleanup' 
 1671  export '. send_static_file' '. execute_dynamic_page' '. do_compile_dynamic_page' 
 1672  export '. find_dynamic_page' 
 1673  export '. forward'