Patch title: Release 90 bulk changes
Abstract:
File: /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/context.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"

constant database true
constant compression os_zlib_filename<>""
constant chunking true
constant conservative false
constant common_path "/common/"+string:pliant_release_number+"/"

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
    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
    # 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_applied
    #
    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 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 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 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 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 TagStack tag_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 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_rights uname ip rights
  arg_rw HttpRequest request ; arg Str uname ip ; arg_rw Str rights
  var Data:User u :> user uname
  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

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 assign_rights "anonymous" ip rights
    each t (user request:user_name):template
      request assign_rights t ip rights
    if request:user_name<>""
      request assign_rights request:user_name ip rights
  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 -> status
  arg_rw HttpRequest request ; arg Data:Site site ; arg Status status
  if not exists:site
    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 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
  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
    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
  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
  request site_default := "/pliant/protocol/http/default.html"
  request area_path := "/"
  request area_root := "/"
  part assign
    request style_name := ""
    request style_options := ""
    var Str lsite := request:stream safe_query "local_site"
    if lsite<>""
      request site_name := lsite
    if request:site_name<>""
      var Data:Site rsite :> site request:site_name
      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)=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)=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:tag_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 "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
  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

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:tag_stack mark
  p execute_style_setup "/pliant/protocol/http/style/default.style"
  p execute_style_setup r:style_name
  p:html_stack initialize
  p:tag_stack initialize

method p unbind
  arg_rw HtmlPage p
  p:html_stack rewind
  p:tag_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
  var Str a := "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2 Final//EN[dq]>[lf]"
  a += "<html>[lf]"
  a += "<head>[lf]"
  if title<>""
    a += "<title>"+html_encode:title+"</title>[lf]"
  if header_message<>""
    a += header_message
  a += "</head>[lf]"
  a += "<body>[lf]"
  if text_message<>""
    a += text_message
  if html_message<>""
    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

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_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 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 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 " 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 '"+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]"+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 := 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 filename) map Function
    check exists: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 filename -> err
  arg_rw HttpServer server ; arg Str filename ; arg Str err
  (var Stream source) open filename in+safe
  if source=failure
    return ""
  pliant_compiler_semaphore request
  var Link:DynamicPage dp :> server find_dynamic_page filename
  if exists:dp
    pliant_compiler_semaphore release
    return ""
  var List:Str lines
  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 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

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 FileInfo info := file_query filename standard
  if info=undefined or info:is_directory
    return failure
  if not (request modified_since info:datetime)
    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 mime := options option "mime" Str
  if mime=""
    var Str ext := filename (filename search_last "." filename:len) filename:len
    mime := query_mime_type ext
  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 remain<>0
    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 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: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 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_path+"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: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
    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 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) ".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 encoded_options := ""
      request send_misc_answer "obsolete"
      return success # there is no such button
  else
    dp :> sp
    context := ""
  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 := 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 "+" " ") "%0D%0A" "%0A"
        pc += "&"+tf:name+"="+value
        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
          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)
    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 := shunt request:answer_header_sent success failure
  else
    status := failure
  page unbind
  if status=success
    request send_footer


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



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


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+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 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_applied := false
    query_log := var List empty_list
    answer_header_sent := false
    answer_footer_sent := false
    answer_extra := var List empty_list
    answer_status := ""
    answer_mime_type := ""
    answer_datetime := undefined
    answer_is_dynamic := true
    answer_size := undefined
    answer_encoding := ""
    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 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 eparse any:command "_" (any request:encoded_path))
      request protocol_level := 0.9
    else
      request send_empty_answer "400 Bad Request"
      return
    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 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
        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 "\" any:(var Str user) ":" any:(var Str password)) or (auth parse any:(var Str user) ":" any:(var Str password))
                var Data:UserSecret u :> user_secret_database:data:user user
                if 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 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 not multipart
        part read_form "read HTTP form"
          var Address buffer := null ; var Int done := 0
          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
        part parse_multipart_form "parse HTTP multipart form"
          request form := ""
          var Int avail := request:server:maximal_form_length
          var Int avail2 := request:server:maximal_file_length
          part multi
            while not request:query_stream:atend
              var Str value
              var Str label := "" ; var Str filename := ""
              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 request:query_stream:atend
                  if cache:len=0
                    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 := 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 request:query_stream:atend and cache:len<boundary:len
                  if cache:len=0
                    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 := 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
                    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
              request:query_stream raw_read addressof:(var Char ch) 1
              request:query_stream readline
              if ch="-"
                leave multi
      request:log trace "form " request:form
      request send_dynamic_answer request:path
    else
      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.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
  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 "+id+" restart at " datetime " from " (http query "remote_ip_address")
    request parse_then_answer
    request:log flush
    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 "+id+" stop at " datetime " from " (http query "remote_ip_address")


define_tcp_server HttpServer http_server
export http_server


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


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 path2 filename
  if (path 0 1)<>"/" and (path search ":" -1)=(-1)
    path2 := (request:path 0 (request:path search_last "/" -1)+1)+path
  else
    path2 := path
  if (path2 eparse "pliant:" any:(var Str remain))
    filename := remain
  eif (path2 search ":" -1)<>(-1)
    filename := path2
  else
    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 filename
    if err=""
      dp :> server find_dynamic_page filename
  var Str rpath := reverse path2
  var Str virtualpath := ""
  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 filename)=""
        dp :> server find_dynamic_page filename
    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_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
  status := success

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