Patch title: Release 87 bulk changes
Abstract:
File: /pliant/protocol/http/server.pli
Key:
    Removed line
    Added line
abstract
  [Pliant HTTP server implementation, according to RFC2616] ; eol
  [This implementation also contains a very powerfull mecanism for dynamic pages.]


# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "/pliant/language/stream.pli"
module "/pliant/language/stream/openmode.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/count.pli"
module "chunked.pli"
module "/pliant/language/compiler.pli"
module "/pliant/language/optimizer.pli"
module "/pliant/language/context.pli"
module "/pliant/language/os.pli"
module "/pliant/admin/file.pli"

submodule "/pliant/protocol/common/tcp_server.pli"
module "/pliant/protocol/common/misc.pli"
module "/pliant/protocol/common/mime.pli"
module "/pliant/fullpliant/user.pli"
module "/pliant/fullpliant/login.pli"
module "site.pli"

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"

module "proxy.pli"

module "filters.pli"

constant database true
constant compression os_zlib_filename<>""
constant chunking true
constant conservative false

constant http_seed_bits 128
constant http_rc4_laps 3
constant http_sign_secret_bits 256
constant http_cipher_secret_bits 512

(gvar TraceSlot http_trace) configure "HTTP server"

doc
  ['DynamicPage' contains all informations related to a compiled dynamic page.] ; eol
  [Dynamic pages are compiled on the fly, the first time they are requested, and stored in the 'dynamic_pages' dictionary.]

public
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


# styles issues
gvar Dictionary html_styles
gvar Sem html_styles_sem


doc
  ['HttpServer' contains the informations about the configuration of the HTTP server. The structure is built and filled when you call 'http_server' function.]

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 Float protocol_level <- 1.1
    if conservative
      field Float protocol_level <- 1.0 
    else
      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

TcpServer maybe HttpServer


doc
  ['HttpRequest' contains all information about the current client HTTP request.]

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 CBool keep_alive_applied
    #
    field Str url_path
    field Str url_options
    field Str command
    field Str encoded_path path
    field Str encoded_options 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 site_default
    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 Link:Stream query_stream
    field CBool answer_header_sent answer_footer_sent
    field Str answer_status           # status message that will be returned at http level
    field Str answer_mime_type
    field Str answer_encoding
    field Int answer_size
    field DateTime answer_datetime
    field CBool answer_is_dynamic
    field Str answer_mime_type
    field Int answer_size
    field Str answer_encoding
    field CBool answer_chunked
    field List answer_extra
    field Link:Stream answer_stream
    field List temp_files
    field Str command
    field TraceSession log
    field Address log_mark

doc
  ['HtmlPage' is the status of the dynamic page that is built as an answer to the current http request.]

public
  type HtmlPage
    field Link:Stream http_stream
    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


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


implicit site_secret_database
  if data:sign_secret=""
    data sign_secret := random_string http_sign_secret_bits\8 # a 256 bit secret should be enough since the MD5 signature is 128 bits
    store
  if data:cipher_secret=""
    data cipher_secret := random_string http_cipher_secret_bits\8
    store
  if data:sign_secret2=""
    data sign_secret2 := random_string http_sign_secret_bits\8
    store
  if data:cipher_secret2=""
    data cipher_secret2 := random_string http_cipher_secret_bits\8
    store

method request generate_signature data -> sign
  arg HttpRequest request ; arg Str data sign
  if site_secret_database:data:sign_secret<>""
    sign := base64_alt_encode (string_md5_binary_signature data+" "+request:user_name+" "+request:user_shaker+" "+site_secret_database:data:sign_secret)
  else
    sign := ""
 
method request check_signature data sign -> status
  arg_rw HttpRequest request ; arg Str data sign ; arg Status status
  if sign=(request generate_signature data)
    status := success
  eif site_secret_database:data:sign_secret2<>"" and sign=base64_alt_encode:(string_md5_binary_signature data+" "+request:user_name+" "+request:user_shaker+" "+site_secret_database:data:sign_secret2)
    status := success
  eif request:user_name<>"" and sign=base64_alt_encode:(string_md5_binary_signature data+"   "+site_secret_database:data:sign_secret)
    status := success
  else
    request:log trace "invalid signature"
    status := failure


method request cipher clear -> ciphered
  arg HttpRequest request ; arg Str clear ciphered
  ciphered := base64_alt_encode (cipher clear site_secret_database:data:cipher_secret http_seed_bits http_rc4_laps)

method request uncipher ciphered alternate -> clear
  arg HttpRequest request ; arg Str clear ciphered ; arg CBool alternate
  clear := uncipher base64_alt_decode:ciphered (shunt alternate site_secret_database:data:cipher_secret2 site_secret_database:data:cipher_secret) http_seed_bits http_rc4_laps

export '. generate_signature' '. check_signature'
export '. cipher' '. uncipher'   


method request allowed name -> a
  arg_rw HttpRequest request ; arg Str name ; arg CBool a
  a := request:user_is_admin or (request:rights first name)<>null and name<>""
  # name<>"" is not really needed if user.pdb is correct, but who knows

method request what_file path -> filename
  arg HttpRequest request ; arg Str path filename
  filename := request:area_root+(path request:area_path:len path:len)


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 step -1
      var Data:User u :> user (shunt lap=0 "anonymous" request:user_name)
      if u:style_options<>""
        request style_options += "[lf]"+u:style_options
      each r u:right
        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))
          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:user_auth_level " :" rights
  if request:user_name<>""
    if not (login_record request:user_name ip (shunt request:user_is_admin "administrator" "HTTP "+(string request:user_auth_level)))
      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 CBool simulate ; arg Status status
method request try_site site -> status
  arg_rw HttpRequest request ; arg Data:Site site ; arg Status status
  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 Int port)) and site:port<>port and site:port=defined
      return failure
  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 Int port)) and site:port<>port and site:port=defined
    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
  var Str path := request path
  if path:len>0 and (path path:len-1)="/"
    path += "index.html"
  var Str ext := 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 area_path := "/"
  request area_root := site root
  request site_default := site default
  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)
    var Str p := a path
    if (path 0 p:len)=p
      var Int l := p len
      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+"[lf]"+request:style_options
  if 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 := "/"
  request site_default := "/pliant/protocol/http/default.html"
  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
      if (request try_site rsite)=success
        leave assign
      var Data:NameHost logical :> name_database:data:host rsite:computer
      if exists:logical and logical:physical=computer_fullname
        request forward := "tcp://127.0.0.1/client/"+(string logical:http_port)
        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
      if s:ip<>"" and (request try_site s)=success
        leave assign
    var Str site_name := request site_name
    if (exists name_database:data:host:site_name) and name_database:data:host:site_name:physical=computer_fullname and computer_fullname<>""
      request forward := "tcp://127.0.0.1/client/"+(string name_database:data:host:site_name:http_port)
    # the name was wrong, so fallback to the default site
    if (request try_site site:computer_fullname false)=success
    if (request try_site site:computer_fullname)=success
      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_name="localhost"
      void
    eif http_proxy_running and (request:stream query "remote_ip_address")="127.0.0.1" and request:browser=http_proxy_browser
      # secured proxy
      var Pointer:Int port :> http_proxy_ports first request:site_name
      if http_proxy_user<>"" and exists:port
        request forward := "zchannel://"+request:site_name+"/user/"+(string port+500)+"/"+http_proxy_user+"/"+http_proxy_password
        console "+"
      else
        request forward := "tcp://"+request:site_name+"/client/80"
        console "-"
    else
      request:log trace "no matching site"
      request user_is_admin := false  
  plugin assign_site
  

export '. allowed'


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


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

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 begin_end_hook_prototype fun
  arg_rw HtmlPage p ; arg Function fun
  indirect


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

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

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 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
  p text_hook_prototype text p:text_hook

function optimize_constant_text gc
  arg_rw GeneratorContext gc
  var Link:Instruction i :> gc first_instruction
  while addressof:i<>null
    var Pointer:Function f :> i function
    if f=(the_function '. text' HtmlPage Str)
      if i:1:where=argument_constant
        var Link:Str encoded :> new Str (html_encode (i:1:constant map Str) true)
        var Link:Instruction i2 :> instruction (the_function '. html_encoded_text' HtmlPage Str) i:0 (argument mapped_constant Str encoded)
        gc insert_after_instruction i i2
        gc remove i
        i :> i2
    i :> i next_instruction

record_optimizer_function optimize_constant_text "pliant optimizer rewrite instructions"


method p execute_style_bloc_prototype fun
  arg_rw HtmlPage p ; arg Function fun
  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
  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
    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


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
    arg_rw HtmlPage page
    implicit page
      body
  '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_prototype substitute body e:0 substitute name (expression mapped_constant m:name near e)
  e compile_as ee
  var Link:Expression f :> null map Expression
  var Bool ok := track_expression style_setup_prototype "body" ee f
  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
  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 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/"+(string request:protocol_level)+" "+(shunt request:answer_status<>"" request:answer_status "200 OK")
  request http_answer "HTTP/"+(string request:protocol_level "fixed 1")+" "+(shunt request:answer_status<>"" request:answer_status "200 OK")
  if request:server:send_software_release_number
    request http_answer "Server: Pliant/"+string:pliant_release_number
  else
    request http_answer "Server: Pliant"
  if request:answer_is_dynamic
    if request:browser_model="mozilla"
      request http_answer "Pragma: no-cache" # not supported by IE 4
    else
      request http_answer "Expires: 0" # not recommended in RFCs
  eif request:answer_datetime=defined
    request http_answer "Last-Modified: "+(rfc1123_date request:answer_datetime)
  if request:answer_size=defined
    request http_answer "Content-Length: "+(string request:answer_size)
  if request:answer_mime_type<>""
    request http_answer "Content-Type: "+request:answer_mime_type
  if compression and request:answer_encoding<>""
    request http_answer "Content-Encoding: "+request:answer_encoding
  request keep_alive_applyed := request:keep_alive_requested and request:answer_size=defined
  if request:keep_alive_applyed 
  if request:answer_chunked
    request http_answer "Transfer-Encoding: chunked"
  if conservative
    request keep_alive_applied := false
  else
    request keep_alive_applied := request:keep_alive_requested and (request:answer_size=defined or request:answer_chunked)
  if request:keep_alive_applied and request:protocol_level<1.1
    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 answer_header_sent := true

method request send_header options
  arg_rw HttpRequest request ; arg Str options
  var Str status := options option "status" Str
  if status<>""
    request answer_status := status
  var Str mime := options option "mime" Str
  if mime<>""
    request answer_mime_type := mime
  var DateTime dt := options option "datetime" DateTime
  if dt<>undefined
    request answer_datetime := dt
  if (options option "static")
    request answer_is_dynamic := false
  var Int size := options option "size" Int
  if size<>undefined
    request answer_size := size
  else
    if chunking and request:protocol_level>=1.1 and not (options option "nochunked")
      request answer_chunked := true
  if compression and (options option "compressed")
    request answer_encoding := request supported_encoding
  request send_header
  request answer_stream :> request stream
  if request:answer_chunked
    var Link:Stream s :> new Stream
    s open "chunked:" "" out+safe pliant_default_file_system request:answer_stream
    request answer_stream :> s
  if compression and request:answer_encoding<>""
    var Link:Stream s :> new Stream
    s open request:answer_encoding+":" "" out+safe pliant_default_file_system request:answer_stream
    request answer_stream :> s

method request send_footer
  arg_rw HttpRequest request
  request answer_stream :> request stream
  request answer_footer_sent := true
  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 request send_footer
  arg_rw HttpRequest request
  request answered := true


method p bind r
  arg_rw HtmlPage p ; arg_rw HttpRequest r
  p http_request :> r
  p http_stream :> r stream
  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.style"
  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 pliant_default_file_system r:stream
  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
  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 answer_stream :> r stream
    r:stream stream_driver :> drv
  r answer_mime_type := ""
  r answer_datetime := undefined
  r answer_is_dynamic := true
  r answer_size := undefined
  r answer_encoding := ""
  r answer_chunked := false
  r keep_alive_applied := false
  r:stream stream_write_cur := r:stream stream_write_buf
  r:log rewind r:log_mark
  r answer_header_sent := false


method p bind r
  arg_rw HtmlPage p ; arg_rw HttpRequest r
  p http_request :> r
  p http_stream :> r answer_stream
  p options := r 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.style"
  p execute_style_setup r:style_name
  p:html_stack initialize

method p unbind
  arg_rw HtmlPage p
  p:html_stack rewind


method request modified_since since -> m
  arg HttpRequest request ; arg DateTime since ; arg CBool m
  var Pointer:Arrow c :> request:query_log first
  while c<>null
    var Pointer:Str s :> c map Str
    if (s parse word:"If-Modified-Since" ":" any:(var Str timestamp))
      if rfc1123_date:timestamp=since
        return false
    c :> request:query_log next c
  m := true
 

method request send_empty_answer status
  arg_rw HttpRequest request ; arg Str status
  if request:protocol_level>=1
    request http_answer "HTTP/"+(string request:protocol_level)+" "+status
    request http_answer ""

method request send_simple_page title header_message text_message html_message status
  arg_rw HttpRequest request ; arg Str title header_message text_message html_message status
  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 Final//EN[dq]>[lf]"
  page html "<html>[lf]"
  page html "<head>[lf]"
  var Str a := "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2 Final//EN[dq]>[lf]"
  a += "<html>[lf]"
  a += "<head>[lf]"
  if title<>""
    page html "<title>"+html_encode:title+"</title>[lf]"
    a += "<title>"+html_encode:title+"</title>[lf]"
  if header_message<>""
    page html header_message
  page html "</head>[lf]"
  page html "<body>[lf]"
    a += header_message
  a += "</head>[lf]"
  a += "<body>[lf]"
  if text_message<>""
    page text text_message
    a += text_message
  if html_message<>""
    page html html_message
  page html "</body>[lf]"
  page html "</html>[lf]"
    a += html_message
  a += "</body>[lf]"
  a += "</html>[lf]"
  request send_header "status "+string:status+" mime [dq]text/html[dq] size "+(string a:len)
  request:stream writechars a
  request send_footer
  page unbind request

method request send_redirect_answer url permanent
  arg_rw HttpRequest request ; arg Str url ; arg CBool permanent
  request answer_is_dynamic := not permanent
  request:answer_extra append addressof:(new Str "Location: "+url)
  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")

method request send_authentification_request
  arg_rw HttpRequest request
  request answer_is_dynamic := true
  # request:answer_extra append addressof:(new Str "WWW-Authenticate: Digest realm=[dq]"+request:site_name+"[dq] nonce=[dq]"+(string datetime:date)+"[dq]")
  request:answer_extra append addressof:(new Str "WWW-Authenticate: Basic realm=[dq]"+request:site_name+"[dq]")
  request send_simple_page "Please authenticate" "" "" "You must be logged in order to access this page." "401 Unauthorized"


export '. send_empty_answer' '. send_simple_page' '. send_redirect_answer' '. send_authentification_request'
export '. send_header' '. send_footer' '. bind' '. unbind' '. reset_http_answer'
export '. modified_since'


#---------------------------------------------------------------------------
#  compile a dynamic page


gvar Str http_current_pagename
gvar Str http_current_filename
gvar DateTime http_current_datetime

function http_record_dynamic_page filename position function type
  arg Str filename position ; arg Function function ; arg Type type
  var Link:DynamicPage dp :> new DynamicPage
  dp filename := http_current_filename
  dp position := position
  dp datetime := http_current_datetime
  dp checkedat := datetime
  dp changed := false
  dp function :> function
  dp type :> type
  dynamic_pages_sem request
  if (dynamic_pages first filename)=null
    dynamic_pages insert filename true addressof:dp
  else
    dynamic_pages first filename := addressof dp
  dynamic_pages_sem release
  # console "recorded " filename eol

export http_record_dynamic_page


method server find_dynamic_page filename -> dp
  arg_rw HttpServer server ; arg Str filename ; arg Link:DynamicPage dp
  dynamic_pages_sem rd_request
  dp :> (dynamic_pages first filename) map DynamicPage
  if addressof:dp<>null
    if server:dynamic_auto_recompile and datetime:seconds-dp:checkedat:seconds>=server:dynamic_page_recheck_delay
      var DateTime dt := (file_query dp:filename standard) datetime
      if dt=dp:datetime
        dp checkedat := datetime
      else
        dp changed := true
    if dp:changed
      dp :> null map DynamicPage
  dynamic_pages_sem rd_release
  

function mime_filter src dest options fun
  arg_rw Stream src dest ; arg_rw Str options ; arg Function fun
  indirect

function compile_style name
  arg Str name
  html_styles_sem rd_request
  var Pointer:Arrow c :> html_styles first name
  if c<>null
    html_styles_sem rd_release
    return
  html_styles_sem rd_release
  pliant_compiler_semaphore request
  pliant_load_module name the_module:"/pliant/language/basic/safe.pli" 0 (null map Module)
  pliant_compiler_semaphore release


method server do_compile_dynamic_page pagename physical name lines function count -> err
  arg_rw HttpServer server ; arg Str pagename physical name ; arg List:Str lines ; arg_w Link:Function function ; arg_rw Int count ; arg Str err
method server do_compile_dynamic_page filename lines function count -> err
  arg_rw HttpServer server ; arg Str filename ; arg List:Str lines ; arg_w Link:Function function ; arg_rw Int count ; arg Str err
  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) datetime
  http_trace trace "compiling page " filename
  http_current_filename := filename
  http_current_datetime := (file_query filename standard) datetime
  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 CBool within_if := false
  while exists:l
    if (l parse word:"style" (var Str modname)) and ( (l 0 5)="style" or within_if and (l 0 7)="  style")
      eod :> lines next l ; linenum := n+1
    eif (l parse word:"module" (var Str modname)) and ( (l 0 6)="module" or within_if and (l 0 8)="  module")
      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+"' page")
  program append addressof:(new Str "function '"+filename+"' page")
  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 [dq]"+physical+"[dq] "+string:linenum+" 1[0]")
  program append addressof:(new Str "    [0]left_zero_is_at [dq]"+filename+"[dq] "+string:linenum+" 1[0]")
  while exists:l
    program append addressof:(new Str "    "+l)
    l :> lines next l
  var Link:Module module :> new Module
  module name := name
  module name := filename
  if exists:count
    module:properties kmap "pliant style standard button counter" Int := count
  plugin standard_modules
    module include the_module:"/pliant/language/basic/safe.pli"
    module include the_module:"/pliant/language/parser/position.pli"
    module include the_module:"/pliant/protocol/http/server.pli"
    pliant_load_module "/pliant/protocol/http/style/default.style" the_module:"/pliant/language/basic/safe.pli" 0 (null map Module)
    module include the_module:"/pliant/protocol/http/style/default.style"
  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 Function
    function :> (pliant_general_dictionary first filename) map Function
    check exists:function
    pliant_general_dictionary remove name addressof:function
    pliant_general_dictionary remove filename 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 button counter" Int undefined
  module :> null map Module
  pliant_compiler_semaphore release

method server compile_dynamic_page pagename filename -> err
  arg_rw HttpServer server ; arg Str pagename filename ; arg Str err
  var Str ext := filename (filename search_last "." filename:len) filename:len
  var Link:Function filter :> query_mime_dynamic_filter ext
  if not exists:filter
    return "?"
  var Str physical := shunt ext<>".html" filename (filename 0 (filename search_last "." filename:len))+".page"
  var FileInfo info := file_query physical standard
  if info=failure or info:is_directory
    return "?"
  var Link:DynamicPage dp :> server find_dynamic_page filename
  if exists:dp
method server compile_dynamic_page filename -> err
  arg_rw HttpServer server ; arg Str filename ; arg Str err
  (var Stream source) open filename in+safe
  if source=failure
    return ""
  var Stream data ; data open physical in+safe
  if data=failure
    return "?"
  # try again with the compile semaphore locked in order to avoid compiling several times the same thing
  pliant_compiler_semaphore request
  var Link:DynamicPage dp :> server find_dynamic_page filename
  if exists:dp
    pliant_compiler_semaphore release
    return ""
  var Str temp := file_temporary
  (var Stream tmp) open temp out
  var Str opt := ""
  mime_filter data tmp opt filter
  data close
  tmp open temp in
  var List:Str lines
  while not tmp:atend
    lines += tmp readline
  tmp close
  file_delete temp
  err := server do_compile_dynamic_page pagename physical physical lines (var Link:Function function) (null map Int)
  while not source:atend
    lines += source readline
  source close
  err := server do_compile_dynamic_page filename lines (var Link:Function function) (null map Int)
  if exists:function
    http_record_dynamic_page filename filename function (null map Type)
  pliant_compiler_semaphore release
    

function http_precompile filename
  arg Str filename
  var Str err := (var HttpServer server) compile_dynamic_page filename filename
function http_precompile path
  arg Str path
  var Str ext := path (path search_last "." path:len) path:len
  var Str filename := shunt ext<>".html" path (path 0 (path search_last "." path:len))+".page"
  var Str err := (var HttpServer server) compile_dynamic_page filename
  if err<>""
      console "Failed to precompile dynamic page " filename " : " err eol
    console "Failed to precompile dynamic page " filename " : " err eol

export http_precompile


#---------------------------------------------------------------------------
#  send a static page


method request send_static_file filename options -> status
  arg_rw HttpRequest request ; arg Str filename options ; arg Status status
  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) 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_header "status [dq]304 Not modified[dq] static nochunked"
    request send_footer
    return success
  var Stream data ; data open filename in+safe
  if data=failure
    return failure
  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
  var Str mime := options option "mime" Str
  if mime=""
    var Str ext := filename (filename search_last "." filename:len) filename:len
    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
  request send_header "mime "+string:mime+" datetime "+(string info:datetime)+" static size "+(string info:size)
  part send "send static file content"
    var Int remain := info size
    while remain>0 and { var Int step := raw_copy data request:stream 1 remain ; step>0 }
      remain -= step
    request:stream flush anytime
  data close
  if exists:filter
    file_delete tempname
  if remain<>0
    request keep_alive_applyed := false
    request keep_alive_applied := false
  request send_footer
  status := success
  

#---------------------------------------------------------------------------
#  execute and send a dynamic page


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 "&" form:len-offset)+offset
      if((form offset stop-offset) parse any:(var Str name) "=" any:(var Str value))
        if (http_decode:name parse "data|" any:(var Str path) "|" any:(var Str sign))
          path := replace (replace path "(" "&#") ")" ";"
          value := replace http_decode:value "[cr][lf]" "[lf]"
        if (http_decode:name parse "data/" any:(var Str sign) "/" any:(var Str path) )
          path := "/"+(replace (replace path "(" "&#") ")" ";")
          value := replace http_decode:(replace value "+" " ") "[cr][lf]" "[lf]"
          if (request check_signature path sign)=success
            var Data_ data := data_root search_path path false
            data:base:sem request
            var Status status := data:interface set data addressof:value Str
            data:base:sem release
            page:http_request:log trace "database set " path " = " value " " (shunt status=success "" " FAILED")
          else
            page:http_request:log trace "rejected database set " path
            # FIXME (page:env kmap "default data rejected" List) append addressof:(new Str path)
      offset := stop+1
  if request:form<>""
    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+"?"+request:context false
      request send_redirect_answer request:encoded_path+"?"+request:context false
      return true

function http_execute_dynamic_page page f
  arg_rw HtmlPage page ; arg Function f
  indirect

function http_execute_dynamic_sub_page buf f
  arg Address buf ; arg Function f
  indirect

if database
  module "/pliant/appli/database.pli"
  module "/pliant/language/data/string_cast.pli"


method request send_file filename virtualpath -> status
  arg_rw HttpRequest request ; arg Str filename virtualpath ; arg Status status
method page execute_dynamic_page path -> status
  arg_rw HtmlPage page ; arg Str path ; arg ExtendedStatus status
  later

method request send_misc_answer name
  arg_rw HttpRequest request ; arg Str name
  request send_header "mime [dq]text/html[dq]"
  (var HtmlPage page) bind request
  page execute_dynamic_page "/common/misc/"+name+".html"
  page unbind
  request send_footer

method request send_dynamic_file filename virtualpath -> status
  arg_rw HttpRequest request ; arg Str filename virtualpath ; arg Status status
  var Link:DynamicPage sp :> request:server find_dynamic_page filename
  if not exists:sp
    var Str err := request:server compile_dynamic_page filename
    if err<>""
      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"
      return success
    sp :> request:server find_dynamic_page filename
  if not exists:sp
    return failure
  var Link:DynamicPage dp ; var Str context
  if ("&"+request:form+"&"+request:url_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)
  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)
    button := http_decode button
    var Str context := request uncipher http_decode:scontext false
    context := request uncipher http_decode:scontext false
    signature := http_decode signature
    if (request check_signature button+" "+context signature)=success
      void
    eif { context := request uncipher http_decode:scontext true ; (request check_signature button+" "+context signature)=success }
      void
    else
      request form := "" ; request url_options := ""
      var Str filename2 := request what_file "/misc/signature.html"
      request send_file filename2 ""
      request form := "" ; request encoded_options := ""
      request send_misc_answer "signature"
      return success # wrong signature
    dp :> request:server find_dynamic_page http_decode:button
    if not exists:dp and (button parse any:(var Str modulename) "|" any)
      if modulename:len>4 and (modulename modulename:len-4 4)=".pli"
        pliant_compiler_semaphore request
        pliant_load_module modulename the_module:"/pliant/language/basic/safe.pli" 0 (null map Module)
        pliant_compiler_semaphore release
        dp :> request:server find_dynamic_page http_decode:button
    if not exists:dp and (button parse any:(var Str modulename) ".pli/" any) and (modulename 0 1)="/"
      pliant_compiler_semaphore request
      pliant_load_module modulename+".pli" the_module:"/pliant/language/basic/safe.pli" 0 (null map Module)
      pliant_compiler_semaphore release
      dp :> request:server find_dynamic_page http_decode:button
    if not exists:dp and (button parse any:(var Str modulename) ".page/" any) and (modulename 0 1)="/"
      request:server compile_dynamic_page modulename+".page"
      dp :> request:server find_dynamic_page http_decode:button
    if not exists:dp
      request form := "" ; request url_options := ""
      var Str filename2 := request what_file "/misc/obsolete.html"
      request send_file filename2 ""
      request form := "" ; request encoded_options := ""
      request send_misc_answer "obsolete"
      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
  request send_header "mime [dq]text/html; charset=iso-8859-1[dq] datetime "+(string dp:datetime)+" compressed chunked"
  (var HtmlPage page) bind request
  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_end_hook_prototype page:begin_hook
        http_execute_dynamic_page page dp:function
        page begin_end_hook_prototype page:end_hook
    status := success
    status := shunt request:answer_header_sent success failure
  eif { var Pointer:Type t :> unpointerto (dp:function arg 0):type ; exists t }
    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 := addressof:page
      eif (tf:properties first "pliant editable")<>null and ("&"+request:form+"&" eparse any (pattern "&"+tf:name+"=") any:(var Str value) "&" any)
        value := replace (replace value "+" " ") "%0C%0A" "%0A"
        pc += "&"+tf:name+"="+value
        value := replace http_decode:value "[cr][lf]" "[lf]"
        from_string (buf translate Byte tf:offset) tf:type value "db"
        from_string (buf translate Byte tf:offset) tf:type http_decode:value "db"
      eif ("&"+context+"&" eparse any (pattern "&"+tf:name+"=") any:value "&" any)
        pc += "&"+tf:name+"="+value
        if database and tf:type:is_data
          (buf translate Byte tf:offset) map Data_ := data_root search_path http_decode:value false
        else
          value := replace http_decode:value "[cr][lf]" "[lf]"
          from_string (buf translate Byte tf:offset) tf:type value "db"
          from_string (buf translate Byte tf:offset) tf:type http_decode:value "db"
    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:(var Str value) "&" any:(var Str remain))
      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_y+"+"+http_encode:id+"+"+(request cipher pc)+"+"+(request generate_signature id+" "+pc)
    request context := "button-"+string:pos_x+"-"+string:pos_y+"-"+http_encode:id+"-"+(request cipher pc)+"-"+(request generate_signature id+" "+pc)
    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_end_hook_prototype page:begin_hook
        http_execute_dynamic_sub_page buf dp:function
        page begin_end_hook_prototype page:end_hook
    t destroy_instance buf
    memory_free buf
    status := success
    status := shunt request:answer_header_sent success failure
  else
    status := failure
  request send_footer
  page unbind request
  page unbind
  if status=success
    request send_footer


#---------------------------------------------------------------------------
#  studying client query
method request send_dynamic_answer path -> status
  arg_rw HttpRequest request ; arg Str path ; arg Status status
  if (path (path search_last "." path:len) path:len)=".html"
    var Str filename := request what_file path
    filename := (filename 0 (filename search_last "." filename:len))+".page"
    if (request send_dynamic_file filename "")=success
      return success
  eif (path path:len-1)="/"
    var Str filename := request what_file path+"index.html"
    filename := (filename 0 (filename search_last "." filename:len))+".page"
    if (request send_dynamic_file filename "")=success
      return success
  var Str rpath := reverse path
  var Str virtualpath := ""
  while (rpath eparse any:(var Str rextra) "/" any:(var Str rbase))
    virtualpath := "/"+reverse:rextra+virtualpath
    var Str filename := request what_file reverse:rbase+"/virtual_tree.page"
    if (request send_dynamic_file filename virtualpath)=success
      return success
    rpath := rbase
  status := failure


method request send_file filename virtualpath -> status
  arg_rw HttpRequest request ; arg Str filename virtualpath ; arg Status status
  var Str ext := filename (filename search_last "." filename:len) filename:len
  if request:area_mode="dynamic" and (query_mime_dynamic_filter ext)=(query_mime_dynamic_filter ".pli") and virtualpath="" and not (request allowed "administrator")
    return    
  if request:area_mode<>"static" or (request allowed "administrator")
    if not ( (request:url_options parse "filter_" any:(var Str ext) _ any) or (request:url_options parse "filter_" any:(var Str ext)) ) or (exists query_mime_dynamic_filter:ext)
      if (request send_dynamic_file filename virtualpath)=success
        return success
      var Str err := request:server compile_dynamic_page request:url_path filename
      if err<>"?"
        if err=""
          if (request send_dynamic_file filename virtualpath)=success
            return success
        else
          request send_simple_page "Bug in page "+request:url_path "" "There is a bug in the dynamic page "+request:url_path+".[lf]" "<PRE>[lf]"+(replace html_encode:err "&#10;" "[lf]")+"[lf]<PRE>[lf]" "500 Internal Server Error"
          return success
  if (request send_static_file filename (http_decode request:url_options))=success
    return success
  if (request what_file "/misc/not_found.html")=filename
    request send_simple_page "Not found" "" "The requested page does not exist on this server." "" "404 Not Found"
    return success
  eif (request what_file "/misc/enter_key_pressed.html")=filename
    request send_simple_page "You pressed enter key ..." "" "Please use buttons to submit, not enter key." "" "200 OK"
    return success
  eif (request what_file "/misc/not_allowed.html")=filename
    request send_simple_page "Not allowed" "" "You are not allowed to access the requested page." "" "403 Forbidden"
    return success
  eif (request what_file "/misc/signature.html")=filename
    request send_simple_page "Wrong signature" "" "The context you sent to the server is not properly signed. Please reload the previous page in order to get an updated signature of the context." "" "400 Bad request"
    return success
  eif (request what_file "/misc/obsolete.html")=filename
    request send_simple_page "Obsolete" "" "You are trying to access an absolete page. Please reload the previous page in order to get an updated link." "" "410 Gone"
    return success
  else
    return failure

#---------------------------------------------------------------------------
#  studying client query

method request answer
  arg_rw HttpRequest request
  if not (request allowed "read")
    if request:user_name=""
      request send_authentification_request
    else
      var Str filename2 := request what_file "/misc/not_allowed.html"
      request send_file filename2 ""
      request:log trace "requested a not allowed page " request:url_path
    return
  var Str pagename := request url_path
  var Str filename := request what_file pagename+(shunt (pagename pagename:len-1)="/" "index.html" "")
  if (request send_file filename "")=success
    return
  if (pagename pagename:len-1)<>"/"
    var Str dirname := request what_file pagename+"/"
    var FileInfo info := file_query dirname standard
    if info=defined and info:is_directory and request:protocol_level>=1
      var Str sitename := shunt request:site_name<>"" request:site_name (request:stream query "local_ip_address")
      request send_redirect_answer "http://"+sitename+pagename+"/" true
      return
  var Str virtualpage := reverse pagename
  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
      return
    virtualpage := base
    request:log trace "requested an unknown page filename=" string:filename " pagename=" string:pagename
  var Str filename2 := request what_file "/misc/not_found.html"
  request send_file filename2 ""


function find_browser_identity id model release
  arg Str id ; arg_w Str model ; arg_w Float release
  var Str value := lower id
  if (value parse word:"pliant" "/" release any)
    model := "pliant"
  eif (value parse any word:"opera" "/" release any) or (value parse any word:"opera" release any)
    model := "opera"
  eif (value parse any word:"msie" release any)
    model := "ie"
  eif (value parse any word:"konqueror" "/" release any) or (value parse any word:"safari" "/" release any)
    model := "konqueror"
  eif (value parse any word:"compatible" any)
    model := "" ; release := undefined
  eif (value parse word:"mozilla" "/" release any)
    model := shunt release<5 "netscape" "mozilla"
  else
    model := "" ; release := undefined
  plugin browser_identity


method request browser_walkaround
  arg_rw HttpRequest request
  if request:browser_model="opera" or request:browser_model="ie"
    if request:supported_encoding="deflate"
      request supported_encoding := "gzip"
  plugin browser_walkaround
  
method request forward target extra
  arg_rw HttpRequest request ; arg Str target extra
  plugin forward_begin
  var Link:Stream s :> request stream
  s stream_flags := s:stream_flags .or. noautopost
  var Link:Stream d :> new Stream
  d open target in+out+cr+lf+safe
  d open target in+out+cr+lf+safe+noautopost
  if d=failure
    return
  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
  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 size2) ; size2<>0 }
      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) ; size1<>0 }
    d raw_write adr1 size1
    d flush anytime
  d safe_configure "shutdown"
  sem request ; sem release
  plugin forward_end
     

function digest s -> h
  arg Str s h
  h := lower string_md5_hexa_signature:s

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
    keep_alive_applied := false
    query_log := var List empty_list
    answered := false
    answer_header_sent := false
    answer_footer_sent := false
    answer_extra := var List empty_list
    answer_status := ""
    answer_mime_type := ""
    answer_size := undefined
    answer_datetime := undefined
    answer_is_dynamic := true
    answer_size := undefined
    answer_chunked := false
    answer_stream :> request stream
    log_mark := request:log mark
  var Pointer:Stream http :> request stream
  part parse "parse HTTP request"
    var Str cmd := http readline ## section "parse_then_answer header"
    request query_first_line := cmd
    request:log trace "query " cmd
    var Str command protocol
    if (cmd parse any:command _ (any request:url_path) _ any:(var Str protocol))
      if (request:url_path eparse "http://" any "/" any:(var Str remain))
        request url_path := "/"+remain
    if (cmd eparse any:command _ (any request:encoded_path) _ any:(var Str protocol))
      if (request:encoded_path eparse "http://" any "/" any:(var Str remain))
        request encoded_path := "/"+remain
      if not (protocol parse word:"HTTP" "/" request:protocol_level)
        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))
    eif (cmd eparse any:command "_" (any request:encoded_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:protocol_level>=1.1
      request keep_alive_requested := true
    request keep_alive_requested := request:protocol_level>=1.1
    if (request:encoded_path parse any:(var Str base) "?" (any request:encoded_options))
      request encoded_path := base
    else
      request keep_alive_requested := false
    if (request:url_path parse any:(var Str base) "?" (any request:url_options))
      request url_path := base
    else
      request url_options := ""
      request encoded_options := ""
    request command := command
    request path := http_decode request:encoded_path
    request options := http_decode request:encoded_options
    var Int length := undefined
    var CBool chunked := false
    var CBool multipart := false
    var CBool continue := false
    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_length
          request:query_log append addressof:(new Str param)
          request:log trace "option " param
        else
          header_length := request:server:maximal_header_length
        if (param parse any:tag ":" any:value)
          tag := lower tag
          if tag="host"
            request site_name := value 0 (value search ":" value:len)
          eif tag="content-length"
            if not (value parse length)
              request send_empty_answer "400 Bad Request" ; return
          eif tag="transfer-encoding" and (value parse acword:"chunked" any)
            chunked := true
          eif tag="content-type"
            if (value parse acword:"multipart" any acword:"boundary" "=" any:(var Str boundary) )
              multipart := true ; boundary := "[cr][lf]--"+boundary
          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:browser_model request:browser_release
          eif tag="accept-language"
            request lang := value
          eif compression and tag="accept-encoding"
            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" ""
          eif tag="authorization"
            if (value parse acword:"basic" any:(var Str encoded))
              var Str auth := base64_decode encoded
              if (auth parse any:(var Str user) ":" any:(var Str password))
                var Data:UserSecret u :> user_secret_database:data:user user
                if request:server:configure and user=request:server:admin_user and password=request:server:admin_password and (request:stream query "remote_ip_address")="127.0.0.1"
                if u:password_md5=string_md5_hexa_signature:password
                  request user_name := user
                  request user_auth_level := 1
                  request user_is_admin := true
                eif u:password_md5=string_md5_hexa_signature:password
                  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+":"+digest:A2
              console "signature for "+user+" is: " answer eol
              var Str response := value option "response=" Str
              if response=answer
                console "YES !" eol
  request browser_walkaround
  request assign_user ## section "parse_then_answer user" ; how "" section "method assign_user"
  request assign_site ## how "" section "method assign_site"
  if request:forward<>""
    request forward request:forward "Origin-IP: "+(request:stream query "remote_ip_address")
    return
  if continue
    request send_empty_answer "100 Continue"
  request:query_stream :> new Stream
  if length<>undefined
    request:query_stream open "count:" "size "+string:length in+safe pliant_default_file_system request:stream
  eif chunked
    request:query_stream open "chunked:" "" in+safe pliant_default_file_system request:stream
  else
    request:query_stream open "count:" "size 0" in+safe pliant_default_file_system request:stream
  plugin answer_begin
  part answer "site '"+request:site_name+"' user '"+request:user_name+"' command "+cmd
    if not (request allowed "read")
      if request:user_name=""
        request send_authentification_request
      else
        request send_misc_answer "not_allowed"
        request:log trace "requested a not allowed page " request:encoded_path
      leave answer
    if request:style_name<>""
      compile_style request:style_name
    if request:forward<>""
      request forward request:forward "Origin-IP: "+(request:stream query "remote_ip_address")
    eif command="GET"
      request answer
    if command="GET"
      if query_mime_type:(request:path (request:path search_last "." request:path:len) request:path:len)<>""
        if (request send_static_file (request what_file request:path) "")=success
          leave answer
      if (request send_dynamic_answer request:path)=success
        leave answer
      if (request:path request:path:len-1)<>"/"
        var FileInfo info := file_query (request what_file request:path+"/") standard
        if info=defined and info:is_directory and request:protocol_level>=1
          request send_redirect_answer "http://"+(shunt request:site_name<>"" request:site_name (request:stream query "local_ip_address"))+request:encoded_path+"/" true
          leave answer
      var Str filename := request site_default
      filename := (filename 0 (filename search_last "." filename:len))+".page"
      if (request send_dynamic_file filename request:path)=failure
        request:log trace "requested an unknown page " request:encoded_path
        request send_simple_page "Not found" "" "The requested page does not exist on this server." "" "404 Not Found"
    eif command="POST" ## section "parse_then_answer POST"
      if length=undefined or length<0
        request send_empty_answer "411 Length Required" ; leave answer
      eif length>(shunt multipart request:server:maximal_file_length request:server:maximal_form_length)
        request send_empty_answer "413 Request Entity Too Large" ; leave answer
      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 step) length-done
            buffer := memory_resize buffer done+step null
            memory_copy buf (buffer translate Byte done) step
            done += step
          if done=length
            request:form set buffer length true
          while not request:query_stream:atend and done<request:server:maximal_form_length
            request:query_stream read_available (var Address adr) (var Int size)
            buffer := memory_resize buffer done+size null
            memory_copy adr (buffer translate Byte done) size
            done += size
          request:form set buffer done 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 step) length-done
            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_length
          var Int avail2 := request:server:maximal_file_length
          part multi
            while not form:atend
            while not request:query_stream:atend
              var Str value
              var Str label := "" ; var Str filename := ""
              while { var Str line := form readline ; request:log trace "multipart_form " line ; line<>"" }
              while { var Str line := request:query_stream readline ; request:log trace "multipart_form " line ; line<>"" }
                if not (line parse any word:"name" "=" "[dq]" any:label "[dq]" ";" word:"filename" "=" "[dq]" any:filename "[dq]" any)
                  line parse any word:"name" "=" "[dq]" any:label "[dq]" any
                  line parse any word:"filename" "=" "[dq]" any:filename "[dq]" any
              if (label parse word:"file" _ word:"upload" _ any:(var Str label2))
                label := label2
                var Str temp := file_temporary
                var Str name := replace filename "\" "/"
                name := name (name search_last "/" -1)+1 name:len
                value := string:temp+" remote_path "+string:filename+" remote_name "+string:name
                request:temp_files append addressof:(new Str value)
                (var Stream data) open value out+safe
                var Str cache := "[cr][lf]" ; var Int drop := 2
                while cache:len<boundary:len and not form:atend
                while cache:len<boundary:len and not request:query_stream:atend
                  if cache:len=0
                    var Address a := memory_search form:stream_read_cur (cast form:stream_read_stop Int).-.(cast form:stream_read_cur Int) boundary:characters 1
                    var Address a := 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
                    if a=null
                      a := form stream_read_stop
                    var Int step := (cast a Int).-.(cast form:stream_read_cur Int)
                    data raw_write form:stream_read_cur step ; avail2 -= step
                    form stream_read_cur := a
                  form raw_read addressof:(var Char ch) 1 ; cache += ch
                      a := request:query_stream stream_read_stop
                    var Int step := (cast a Int).-.(cast request:query_stream:stream_read_cur Int)
                    data raw_write request:query_stream:stream_read_cur step ; avail2 -= step
                    request:query_stream stream_read_cur := a
                  request:query_stream raw_read addressof:(var Char ch) 1 ; cache += ch
                  while cache<>(boundary 0 cache:len)
                    if drop=0
                      data raw_write cache:characters 1 ; avail2 -= 1
                    else
                      drop -= 1
                    cache := cache 1 cache:len
                  if avail2<0
                    request send_empty_answer "413 Request Entity Too Large" ; leave answer
                data close
                request:log trace "file upload " value " -> " (file_query temp standard):size " bytes"
              else
                value := ""
                var Str cache := ""
                while not form:atend and cache:len<boundary:len
                while not request:query_stream:atend and cache:len<boundary:len
                  if cache:len=0
                    var Address a := memory_search form:stream_read_cur (cast form:stream_read_stop Int).-.(cast form:stream_read_cur Int) boundary:characters 1
                    var Address a := 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
                    if a=null
                      a := form stream_read_stop
                    var Int step := (cast a Int).-.(cast form:stream_read_cur Int)
                    (var Str temp) set form:stream_read_cur step false
                      a := request:query_stream stream_read_stop
                    var Int step := (cast a Int).-.(cast request:query_stream:stream_read_cur Int)
                    (var Str temp) set request:query_stream:stream_read_cur step false
                    value += temp ; avail -= step
                    form stream_read_cur := a
                  form raw_read addressof:(var Char ch) 1 ; cache += ch
                    request:query_stream stream_read_cur := a
                  request:query_stream raw_read addressof:(var Char ch) 1 ; cache += ch
                  while cache<>(boundary 0 cache:len)
                    (var Str temp) set cache:characters 1 false
                    value += temp ; avail -= 1
                    cache := cache 1 cache:len
                  if avail<0
                    request send_empty_answer "413 Request Entity Too Large" ; leave answer
              request form += "&"+http_encode:label+"="+http_encode:value
              form raw_read addressof:(var Char ch) 1
              form readline
              request:query_stream raw_read addressof:(var Char ch) 1
              request:query_stream readline
              if ch="-"
                leave multi
          form close
        file_delete form_temp
      request:log trace "form " request:form
      request answer
      request send_dynamic_answer request:path
    else
      var Str virtualpage := reverse request:url_path
      var Str virtualpage := reverse request: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
        var Str virtualfile := request what_file reverse:base+"/virtual_tree.page"
        if (request send_dynamic_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

method server service http
  arg_rw HttpServer server ; arg_rw Stream http
  http line_limit := server maximal_header_length
  var HttpRequest request
  request server :> server
  request:log bind http_trace
  request:log trace "connection start at " datetime " from " (http query "remote_ip_address")
  var Str id := generate_id
  request:log trace "connection "+id+" start at " datetime " from " (http query "remote_ip_address")
  request stream :> http
  var CBool first := true
  part one_request
    if http=failure
      leave one_request
    var CBool ae
    part wait "wait for "+(shunt first "first" "next")+" HTTP request beginning"
      if first
        ae := http atend
      else
        http safe_configure "timeout "+(string server:keep_alive_timeout)
        ae := http atend
        http safe_configure "timeout ?"
    if ae
      leave one_request
    if not first
      request:log trace "connection restart at " datetime " from " (http query "remote_ip_address")
      request:log trace "connection "+id+" restart at " datetime " from " (http query "remote_ip_address")
    request parse_then_answer
    if request:keep_alive_applyed
      http flush async
    request:log flush
    if request:keep_alive_applyed
    if request:keep_alive_applied
      http flush async
      http safe_configure "timeout "+(string server:keep_alive_timeout)
      while not request:query_stream:atend
        request:query_stream read_available (var Address adr) (var Int size)
      first := false
      restart one_request
  request temporary_cleanup
  request:log trace "connection stop at " datetime " from " (http query "remote_ip_address")
  request:log trace "connection "+id+" stop at " datetime " from " (http query "remote_ip_address")


method server start_checkup -> status
  arg_rw HttpServer server ; arg Status status
  if server:configure
    server admin_user := keyboard_input "Please enter administrator user id: "
    server admin_password := keyboard_input_password "And now the administrator password: "
  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 have to start it with 'configure' option. "
      console "The right command might be:" eol
      console "pliant module /pliant/protocol/http/server.pli command 'http_server" (shunt server:port=80 "" " port "+(string server:port)) " configure'" eol
      return failure
  status := success
  plugin server_start


define_tcp_server HttpServer http_server
export http_server


#---------------------------------------------------------------------------
#  HTML pages definition functions


method page execute_dynamic_page pagename1 -> status
  arg_rw HtmlPage page ; arg Str pagename1 ; arg ExtendedStatus status
method page execute_dynamic_page path -> status
  arg_rw HtmlPage page ; arg Str path ; arg ExtendedStatus status
  var Pointer:HttpRequest request :> page:http_request
  var Pointer:HttpServer server :> request:server
  var Str pagename filename
  if (pagename1 0 1)<>"/" and (pagename1 search ":" -1)=(-1)
    var Str path := request url_path
    path := path 0 (path search_last "/" -1)+1
    pagename := path+pagename1
  var Str path2 filename
  if (path 0 1)<>"/" and (path search ":" -1)=(-1)
    path2 := (request:path 0 (request:path search_last "/" -1)+1)+path
  else
    pagename := pagename1
  if (pagename parse "pliant:" any:(var Str path))
    filename := path
  eif (pagename search ":" -1)<>(-1)
    filename := pagename
    path2 := path
  if (path2 eparse "pliant:" any:(var Str remain))
    filename := remain
  eif (path2 search ":" -1)<>(-1)
    filename := path2
  else
    filename := request what_file pagename
    filename := request what_file path2
  var Str ext := filename (filename search_last "." filename:len) filename:len
  if ext=".html"
    filename := (filename 0 (filename search_last "." filename:len))+".page"
  var Link:DynamicPage dp :> server find_dynamic_page filename
  if not exists:dp
    var Str err := server compile_dynamic_page pagename filename
    var Str err := server compile_dynamic_page filename
    if err=""
      dp :> server find_dynamic_page filename
  var Str virtualpage := reverse pagename
  var Str rpath := reverse path2
  var Str virtualpath := ""
  while not exists:dp and (virtualpage parse any:(var Str extra) "/" any:(var Str base))
    virtualpath := "/"+reverse:extra+virtualpath
    filename := request what_file reverse:base+"/virtual_tree.html"
  while not exists:dp and (rpath eparse any:(var Str rextra) "/" any:(var Str rbase))
    virtualpath := "/"+reverse:rextra+virtualpath
    var Str filename := request what_file reverse:rbase+"/virtual_tree.page"
    var Link:DynamicPage dp :> server find_dynamic_page filename
    if not exists:dp
      if (server compile_dynamic_page pagename filename)=""
      if (server compile_dynamic_page filename)=""
        dp :> server find_dynamic_page filename
    virtualpage := base
    rpath := rbase
  if not exists:dp or dp:function:nb_args<>1 or (dp:function arg 0):type<>HtmlPage
    return failure:err
  var Str memo_file_name := page file_name
  var Str memo_virtual_path := page virtual_path
  var Str memo_url_path := request url_path
  page file_name := filename
  page virtual_path := virtualpath
  request url_path := pagename
  var Str memo_path := request path ; request path := path
  var Str memo_file_name := page file_name ; page file_name := filename
  var Str memo_virtual_path := page virtual_path ; page virtual_path := virtualpath
  page execute_style_setup dp:function
  http_execute_dynamic_page page dp:function
  request path := memo_path
  page file_name := memo_file_name
  page virtual_path := memo_virtual_path
  request url_path := memo_url_path
  status := success

export '. temporary_cleanup'
export '. send_static_file' '. execute_dynamic_page' '. do_compile_dynamic_page'
export '. find_dynamic_page'
export '. read_data_string' '. read_data_file'
export '. forward'