Patch title: Release 85 bulk changes
Abstract:
File: /pliant/protocol/http/server.pli
Key:
    Removed line
    Added line
abstract
  [Pliant HTTP server implementation, according to RFC2616] ; 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/filesystembase.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 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 Str protocol_level <- "1.0"
    field Float protocol_level <- 1.1
    field CBool keep_alive_connections <- true
    field Float keep_alive_timeout <- 120
    # security issues
    field CBool send_software_release_number <- true
    field Int maximal_header_length <- 2^20
    field Int maximal_form_length <- 2^20
    field Int maximal_file_length <- 2^30
    # configuration issues
    field CBool configure <- false
    field Str admin_user
    field Str admin_password
    field Str simulate
    # statistics
    field Intn hits_count <- 0
    field Intn bytes_count <- 0
    field Sem hits_sem

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 Str url_path
    field Str url_options
    field Str context
    field Link:Type context_type
    field Str form
    field Str user_name
    field Int user_auth_level <- 0
    field CBool user_is_admin <- false
    field Str user_shaker
    field Str browser
    field Str browser_model ; field Float browser_release
    field Str supported_encoding
    field Str lang
    field Str site_name
    field Str area_path area_root
    field Str area_mode
    field Str style_name
    field Str style_options
    field Str forward
    field Dictionary rights
    #
    field Str query_first_line
    field List query_log
    field CBool answered
    field Str answer_status           # status message that 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 List answer_extra
    field List temp_files
    field Str put_file
    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 Dictionary tags
    field Link:Function text_hook
    field Link:Function html_hook
    field Pointer:HttpRequest http_request
    # styling
    field HtmlStack html_stack
    field Dictionary environment
    field Link:Function html_hook text_hook begin_hook end_hook
    # informations from the HTTP request
    field Str file_name
    field Str virtual_path
    field Str options                 # decoded options
    field Dictionary styles
    # http protocol related informations
    field Pointer:HttpRequest http_request
    field CBool read_only_mode <- false
    # fields reserved for styles
    field Int do_not_use_Int <- 0
    field Arrow do_not_use_Arrow
    field Int you_can_use_Int <- undefined
    field Arrow you_can_use_Arrow
    field Dictionary env              # you can store application local datas there


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


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

method request assign_site
  arg_rw HttpRequest request
  if (request:url_path parse "/common/" any)
    request area_path := "/common/"
    request area_root := "/pliant/protocol/http/common/"
  else
    request area_path := "/"
    request area_root := "/"
  part assign
    request area_mode := ""
    request style_name := ""
    request style_options := ""
    var Str lsite := request:stream safe_query "local_site"
    if lsite<>""
      request site_name := lsite
    var CBool simulate := false
    if request:site_name="localhost"
      if request:server:configure
        leave assign
      if request:server:simulate<>""
        request site_name := request:server:simulate
        simulate := true
    if request:site_name<>""
      var Data:Site rsite :> site request:site_name
      if (request try_site rsite simulate)=success
        leave assign
      var Data:NameHost logical :> name_database:data:host 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
        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
      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 default_text_handler text html_encoded
  arg_rw HtmlPage p ; arg Str text ; arg CBool html_encoded
  var Str t
  if html_encoded
    t set text:characters text:len false # same a t := text
  else
    t := html_encode text true
  if (p:do_not_use_Int .and. 1)<>0
    t := replace t " " "&nbsp;"
  p:http_stream writechars t
method p text_hook_prototype text fun
  arg_rw HtmlPage p ; arg Str text ; arg Function fun
  indirect
  # the text must be HTML encoded

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

method p text text

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


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

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


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


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

export '. text' '. html'
method p text text
  arg_rw HtmlPage p ; arg Str text
  p text_hook_prototype (html_encode text true) p:text_hook

export '. html' '. text'


method p html_encoded_text text
  arg_rw HtmlPage p ; arg Str text
  p text_hook_prototype text true p:text_hook
  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_setup_prototype options fun
  arg_rw HtmlPage p ; arg Str options ; arg Function fun
method p execute_style_bloc_prototype fun
  arg_rw HtmlPage p ; arg Function fun
  indirect

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 execute_style_setup_prototype p:http_request:style_options f
  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=Str
    if entry_type:c=Function
      p execute_style_bloc_prototype (c map Function)
    eif entry_type:c=Str
      if (p execute_style_setup (c map Str))=failure
        status := failure
    c :> fun:properties next "style" c


method s search_from start pattern ifnotfound -> pos
  arg Str s ; arg Int start ; arg Str pattern ; arg Int ifnotfound pos
  pos := ((s start s:len) search pattern ifnotfound.-.start)+start

method p dynamic_tag_prototype options fun
  arg_rw HtmlPage p ; arg Str options ; arg Function fun
  indirect

method p tag id options
  arg_rw HtmlPage p ; arg Str id options
  var Pointer:Arrow c :> p:tags first id
  if c=null
    p:http_stream writechars "<"+id+">[lf]"
    return
  if entry_type:c=Str
    var Str value := c map Str
    part substitute
      var Int i1 := value search character:251 -1
      if i1>=0
        var Int i2 := value search_from i1+1 character:252 -1
        if i2>=0
          var Int i3 := value search_from i2+1 character:253 -1
          if i3>=0
            var Int i4 := value search_from i3+1 character:254 -1
            if i4>=0
              var Int i5 := value search_from i4+1 character:255 -1
              if i5>=0
                if (value i2+1 i3-i2-1)=character:250
                  var CBool flag := options option (value i1+1 i2-i1-1)
                  value := (value 0 i1)+(shunt flag (value i3+1 i4-i3-1) (value i4+1 i5-i4-1))+(value i5+1 value:len)
                else
                  var Str param := options option (value i1+1 i2-i1-1) Str
                  if param<>""
                    value := (value 0 i1)+(value i2+1 i3-i2-1)+param+(value i3+1 i4-i3-1)+(value i5+1 value:len)
                  else
                    value := (value 0 i1)+(value i4+1 i5-i4-1)+(value i5+1 value:len)
                restart substitute              
    p:http_stream writechars value
  eif entry_type:c=Function
    p dynamic_tag_prototype options (c map Function)

method p tag_style id style
  arg_rw HtmlPage p ; arg Str id style
  p:tags insert id true addressof:(new Str style)

function tag_option id pre post default -> s
  arg Str id pre post default ; arg Str s
  s := character:251+id+character:252+pre+character:253+post+character:254+default+character:255

function tag_flag id yes no -> s
  arg Str id yes no ; arg Str s
  s := character:251+id+character:252+character:250+character:253+yes+character:254+no+character:255


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

named_expression style_setup_prototype
  method page style_setup_code options
    arg_rw HtmlPage page ; arg Str options
  method page style_setup_code
    arg_rw HtmlPage page
    implicit page
      body
  'record style setup code' (the_function '. style_setup_code' HtmlPage Str) name
  '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 or (e:0 constant Str)=null
    return
  var Link:Str name :> new Str ((e:0 constant Str) map Str)
  if (name 0 1)<>"/"
    name := (e:module:name 0 (e:module:name search_last "/" -1)+1)+name    
  e:module:properties insert "style" false addressof:name
  e compile_as (expression immediat module:name substitute name e:0)
  if e:size=1 and e:0:ident="{}"
    var Link:Expression ee :> expression duplicate style_bloc_prototype substitute body e:0 near e:0
    ee compile
    var Link:Function f :> (pliant_general_dictionary first ". pliant style bloc") map Function
    if exists:f
      e:module:properties insert "style" false addressof:f
      pliant_general_dictionary remove ". pliant style bloc" addressof:f
      e set_void_result
  eif e:size=1 and (e:0 constant Str)<>null
    var Link:Str name :> new Str ((e:0 constant Str) map Str)
    if (name 0 1)<>"/"
      name := (e:module:name 0 (e:module:name search_last "/" -1)+1)+name    
    e:module:properties insert "style" false addressof:name
    e compile_as (expression immediat module:name substitute name e:0)

export '. tag' '. tag_style' tag_option tag_flag style_setup 'record style setup code'
export style '. execute_style_setup'
export style_setup 'record style setup code'
export style


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


method request http_answer line
  arg_rw HttpRequest request ; arg Str line
  request:stream writeline line
  if line:len<>0
    request:log trace "answer " line
  
method request send_header
  arg_rw HttpRequest request
  request log_mark := request:log:mark
  if request:protocol_level<1
    return
  request http_answer "HTTP/"+request:server:protocol_level+" "+(shunt request:answer_status<>"" request:answer_status "200 OK")
  request http_answer "HTTP/"+(string request:protocol_level)+" "+(shunt request:answer_status<>"" request:answer_status "200 OK")
  if request:server:send_software_release_number
    request http_answer "Server: Pliant/"+string:pliant_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 
    request http_answer "Connection: Keep-Alive"
  var Pointer:Arrow c :> request:answer_extra first
  while c<>null
    request http_answer (c map Str)
    c :> request:answer_extra next c
  request http_answer ""
  request:server:hits_sem request
  request:server hits_count += 1
  if request:answer_size=defined
    request:server bytes_count += request answer_size
  request:server:hits_sem release

method 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 tags := var Dictionary empty_dictionary
  p text_hook :> the_function '. default_text_handler' HtmlPage Str CBool
  p html_hook :> the_function '. default_html_handler' HtmlPage Str
  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:stream stream_driver :> drv
  r answer_encoding := ""
  p http_stream :> r stream
  r:stream stream_write_cur := r:stream stream_write_buf
  r:log rewind r:log_mark


method request 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/"+request:server:protocol_level+" "+status
    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]"
  if title<>""
    page html "<title>"+html_encode:title+"</title>[lf]"
  if header_message<>""
    page html header_message
  page html "</head>[lf]"
  page html "<body>[lf]"
  if text_message<>""
    page html html_encode:text_message
    page text text_message
  if html_message<>""
    page html html_message
  page html "</body>[lf]"
  page html "</html>[lf]"
  request send_footer
  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' '. reset_http_answer'
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

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
  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
  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 "  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]")
  while exists:l
    program append addressof:(new Str "    "+l)
    l :> lines next l
  var Link:Module module :> new Module
  module name := name
  if exists:count
    module:properties kmap "pliant style standard button 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
    check exists:function
    pliant_general_dictionary remove name addressof:function
    err := ""
    var Pointer:Arrow c :> module:properties first "style"
    while c<>null
      function:properties insert "style" false c
      c :> module:properties next "style" c
    function:properties insert "module" true addressof:module  
  else
    function :> null map Function
    err := e message
    e id := error_id_noerror
  error_pull_record e
  if exists:count
    count := module:properties kmap "pliant style standard 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
    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)
  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
  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 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_footer
    return success
  var Stream data ; data open filename in+safe
  if data=failure
    return failure
  var Str opt := options
  var Str opt := options+" name "+string:filename
  var Link:Function filter :> query_mime_static_filter ext
  if exists:filter
    var Str tempname := file_temporary
    var Stream temp ; temp open tempname out+safe
    if temp=failure
      return failure
    mime_filter data temp opt filter
    data close ; temp close
    info size := (file_query tempname standard) size
    data open tempname in+safe
    if data=failure
      file_delete tempname
      return failure
  var Str mime := opt option "mime" Str
  if mime=""
    mime := query_mime_type ext
  if mime=""
    mime := "binary/*"
  request answer_mime_type := mime
  request answer_size := info size
  request answer_datetime := info datetime
  request answer_is_dynamic := false
  request answer_encoding := ""
  request send_header
  part send "send static file content"
    var Int remain := info size
    while remain>0 and { var Int step := raw_copy data 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 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 (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
            (page:env kmap "default data rejected" List) append addressof:(new Str path)
            # FIXME (page:env kmap "default data rejected" List) append addressof:(new Str path)
      offset := stop+1
  if request:form<>""
    if request:put_file="" and request:temp_files:first=null and (not (exists request:context_type) or (request:context_type:properties first "http stay")=null)
    if request:temp_files:first=null and (not (exists request:context_type) or (request:context_type:properties first "http stay")=null)
      page reset_http_answer
      request send_redirect_answer request:url_path+"?"+request:context false
      return true

method page begin_html_page
  arg_rw HtmlPage page
  page tag "doctype" ""
  page tag "html" ""
  page tag "head" ""
  page tag "stylesheet" ""
  page tag "script" ""
  page tag "/head" ""
  page tag "body" "url "+(string page:http_request:url_path)
  page tag "page_top" ""

method page end_html_page
  arg_rw HtmlPage page
  if not page:http_request:answered
    page tag "page_bottom" ""
    page tag "/body" ""
    page tag "/html" ""

export '. begin_html_page' '. end_html_page'


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

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
  later

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
    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)
    button := http_decode button
    var Str 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 ""
      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
      request form := "" ; request url_options := ""
      var Str filename2 := request what_file "/misc/obsolete.html"
      request send_file filename2 ""
      return success # there is no such button
  else
    dp :> sp
    context := ""
  request answer_mime_type := "text/html"
  request answer_datetime := dp datetime
  if compression
    request answer_encoding := request supported_encoding
  request send_header
  (var HtmlPage page) bind request
  page options := http_decode request:url_options
  page file_name := dp filename
  page virtual_path := virtualpath
  check dp:function:nb_args=1
  if (dp:function arg 0):type=HtmlPage
    if not page:escape_html_page
      part execute "execute dynamic page "+filename
        page execute_style_setup sp:function
        page begin_html_page
        page begin_end_hook_prototype page:begin_hook
        http_execute_dynamic_page page dp:function
        page end_html_page
        page begin_end_hook_prototype page:end_hook
    status := success
  eif { var Pointer:Type t :> unpointerto (dp:function arg 0):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)
        pc += "&"+tf:name+"="+value
        value := replace http_decode:value "[cr][lf]" "[lf]"
        from_string (buf translate Byte tf:offset) tf:type 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"
    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_html_page
        page begin_end_hook_prototype page:begin_hook
        http_execute_dynamic_sub_page buf dp:function
        page end_html_page
        page begin_end_hook_prototype page:end_hook
    t destroy_instance buf
    memory_free buf
    status := success
  else
    status := failure
  request send_footer
  page unbind request


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


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


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 cmd
  arg_rw HttpRequest request ; arg Str cmd
method request forward target extra
  arg_rw HttpRequest request ; arg Str target extra
  plugin forward_begin
  var Link:Stream s :> request stream
  var Link:Stream d :> new Stream
  d open request:forward in+out+safe
  d open target in+out+cr+lf+safe
  if d=failure
    return
  d writeline cmd
  d writeline request:query_first_line
  var Pointer:Arrow c :> request:query_log first
  while c<>null
    d writeline (c map Str)
    c :> request:query_log next c
  d writeline "Origin-IP: "+(s safe_query "remote_ip_address")
  if extra:len>0
    d writeline extra
  d writeline ""
  d flush anytime
  var Sem sem ; sem request
  thread
    while { d read_available (var Address adr2) (var Int 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
    query_log := var List empty_list
    answered := false
    answer_extra := var List empty_list
    answer_status := ""
    answer_mime_type := ""
    answer_size := undefined
    answer_datetime := undefined
    answer_is_dynamic := true
    log_mark := request:log mark
  var Pointer:Stream http :> request stream
  part parse "parse HTTP request"
    var Str cmd := http readline ## section "parse_then_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: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 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))
      request protocol_level := 0.9
    eif cmd:len<=1
      request keep_alive_applyed := true
      return
    else
      request send_empty_answer "400 Bad Request"
      return
    if request:server:protocol_level<>"1.0" and request:protocol_level>=1.1
    if request:protocol_level>=1.1
      request keep_alive_requested := true
    else
      request keep_alive_requested := false
    if (request:url_path parse any:(var Str base) "?" (any request:url_options))
      request url_path := base
    else
      request url_options := ""
    var Int length := undefined ; var Str tag value
    request command := command
    var Int length := undefined
    var CBool multipart := false
    var CBool continue := false
    var DateTime dt := undefined
    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="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"
                  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
          eif tag="last-modified"
            dt := rfc1123_date value
  request browser_walkaround
  request assign_user ## section "parse_then_answer user" ; how "" section "method assign_user"
  request assign_site ## how "" section "method assign_site"
  plugin answer_begin
  part answer "site '"+request:site_name+"' user '"+request:user_name+"' command "+cmd
    if request:style_name<>""
      compile_style request:style_name
    if request:forward<>""
      request forward cmd
      request forward request:forward "Origin-IP: "+(request:stream query "remote_ip_address")
    eif command="GET"
      request answer
    eif command="POST" ## section "parse_then_answer POST"
      if length=undefined or length<0
        request send_empty_answer "411 Length Required" ; 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
      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
              var Str value
              var Str label := "" ; var Str filename := ""
              while { var Str line := form 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
                  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
                    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
                  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
                  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
                    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
                    value += temp ; avail -= step
                    form stream_read_cur := a
                  form 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
              if ch="-"
                leave multi
          form close
        file_delete form_temp
      request:log trace "form " request:form
      request answer
    eif command="PUT" or command="DELETE"
      if command="PUT"
        if length=defined and length<0
          request send_empty_answer "400 Bad Request" ; leave answer
        if request:put_file=""
          request:put_file := file_temporary
        (var Stream data) open request:put_file out+mkdir+safe
        if data=failure
          request send_empty_answer "500 Internal Server Error" ; leave answer
        if request:protocol_level>=1.1 and continue
          request send_empty_answer "100 Continue"
        if length=defined
          while length>0 and { var Int step := raw_copy http data 1 length ; step>0 }
            length -= step
        else
          while not http:atend
            http read_available (var Address adr) (var Int step)
            data raw_write adr step
        data flush anytime
        if data=failure or (length=defined and length<>0)
          request send_empty_answer "500 Internal Server Error" ; leave answer
        data close
        if dt=defined
          file_configure request:put_file "datetime "+string:dt
      if (request allowed "write")
        var Str virtualpage := reverse request:url_path
        var Str virtualpath := ""
        while (virtualpage parse any:(var Str extra) "/" any:(var Str base))
          virtualpath := "/"+reverse:extra+virtualpath
          var Str virtualfile := request what_file reverse:base+"/virtual_tree_"+command+".html"
          if (request send_file virtualfile virtualpath)=success
            leave answer
          virtualpage := base
      var Str filename2 := request what_file "/misc/not_allowed.html"
      request send_file filename2 ""
    else    
    else
      var Str virtualpage := reverse request:url_path
      var Str virtualpath := ""
      while (virtualpage parse any:(var Str extra) "/" any:(var Str base))
        virtualpath := "/"+reverse:extra+virtualpath
        var Str virtualfile := request what_file reverse:base+"/virtual_tree.html"
        if (request send_file virtualfile virtualpath)=success
          leave answer
        virtualpage := base
      request send_empty_answer "501 Not Implemented"
  plugin answer_end


method request temporary_cleanup
  arg_rw HttpRequest request
  var Pointer:Arrow c :> request:temp_files first
  while c<>null
    file_delete (c map Str)
    c :> request:temp_files remove c
  if request:put_file<>""
    file_delete request:put_file
    request:put_file := ""

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")
  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 parse_then_answer
    if request:keep_alive_applyed
      http flush async
    request:log flush
    if request:keep_alive_applyed
      first := false
      restart one_request
  request temporary_cleanup
  request:log trace "connection stop at " datetime " from " (http query "remote_ip_address")


method server start_checkup -> status
  arg_rw HttpServer server ; arg Status status
  if server:protocol_level<>"1.0" and not server:keep_alive_connections
    error "If you want to desable keep alive connections, then also set HTTP protocol level 1.0"
    return failure
  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
  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
  else
    pagename := pagename1
  if (pagename parse "pliant:" any:(var Str path))
    filename := path
  eif (pagename search ":" -1)<>(-1)
    filename := pagename
  else
    filename := request what_file pagename
  var Link:DynamicPage dp :> server find_dynamic_page filename
  if not exists:dp
    var Str err := server compile_dynamic_page pagename filename
    if err=""
      dp :> server find_dynamic_page filename
  var Str virtualpage := reverse pagename
  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"
    var Link:DynamicPage dp :> server find_dynamic_page filename
    if not exists:dp
      if (server compile_dynamic_page pagename filename)=""
        dp :> server find_dynamic_page filename
    virtualpage := base
  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
  page execute_style_setup dp:function
  http_execute_dynamic_page page dp:function
  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'