Patch title: Release 96 bulk changes
Abstract:
File: /pliant/graphic/console/http_proxy.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/language/data/cache.pli"
module "/pliant/language/stream.pli"
module "/pliant/util/pml/io.pli"
module "/pliant/protocol/common/tcp_server.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/protocol/http/chunked.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/util/encoding/http.pli"
module "/pliant/graphic/browser/client/context.pli"
module "/pliant/graphic/browser/client/connect.pli"
module "/pliant/graphic/ui/client/context.pli"
module "/pliant/graphic/ui/client/connect.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/util/crypto/intn.pli"
module "/pliant/graphic/color/rgb888.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/packed.pli"
module "/pliant/graphic/filter/io.pli"
module "/pliant/language/data/id.pli"
module "/pliant/util/crypto/random.pli"
module "/pliant/util/encoding/base64.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/util/encoding/date.pli"

module "/pliant/graphic/layout/prototype.pli"
module "/pliant/graphic/layout/text.pli"
module "/pliant/graphic/layout/sequence.pli"
module "/pliant/graphic/layout/form.pli"
module "/pliant/graphic/layout/table.pli"
module "/pliant/graphic/layout/restyle.pli"
module "/pliant/graphic/layout/hook.pli"
module "/pliant/graphic/layout/image.pli"
module "/pliant/graphic/layout/draw.pli"


constant url_header "/_"
constant form_size_limit 2^22
constant cache_header "/pliant/proxy/session/"
constant dpi 75
constant gather_infos false
constant frame true
constant css true
constant gecko1 false
constant rounded true
constant rounded_size 4
constant rounded_ground_color (color rgb 224 224 224)
constant rounded_border_color (color rgb 192 192 192)
constant alt false
constant trace false


method l set_sent
   arg_rw LayoutPrototype l
   l http_proxy_flags := l:http_proxy_flags .or. 1

method l reset_sent
   arg_rw LayoutPrototype l
   l http_proxy_flags := l:http_proxy_flags .and. -2
   # also defined as reset_http_proxy_flags in /pliant/graphic/layout/prototype.pli

method l sent -> c
   arg LayoutPrototype l ; arg CBool c
   c := (l:http_proxy_flags .and. 1)<>0


public
  type ConsoleHttpProxy
    tcp_server_fields "Browser HTTP proxy" 80
    field Str root_url
    tcp_server_fields "UI HTTP proxy" 80
    field Str protocol
TcpServer maybe ConsoleHttpProxy
  
define_tcp_server ConsoleHttpProxy console_http_proxy
export console_http_proxy

public
  gvar Int http_proxy_alive_mini := 1
  gvar Int http_proxy_alive_maxi := 120


type ConsoleHttpProxyContext
  field Link:BrowserConsole console
  inherit CachePrototype
  field Link:UIConsole console
  field Link:LayoutStyle style
  field Link:ColorGamut gamut
  field Link:ColorGamut convert_gamut
  field ColorBuffer convert_buffer
  field Arrow convert_speedup
  field Str secret
  if gather_infos
    field Str browser ; field Float ui_release
    field Str user
    field DateTime since alive

method pc color c -> rgb
  arg_rw ConsoleHttpProxyContext pc ; arg LayoutColor c ; arg ColorRGB888 rgb
  var Address pixel := shunt c:gamut:pixel_size>Address:size c:value_or_address (addressof c:value_or_address)
  if (addressof c:gamut)<>(addressof pc:gamut)
    if (addressof pc:convert_gamut)<>(addressof c:gamut)
      pc convert_gamut :> c gamut
      pc:convert_speedup := pc:gamut speedup c:gamut ""
    pc:gamut convert c:gamut pixel (addressof pc:convert_buffer) 1 pc:convert_speedup
    pixel := addressof pc:convert_buffer
  rgb := pixel map ColorRGB888


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


method l recurse_html a http
  oarg_rw LayoutPrototype l ; arg Address a ; arg_rw Stream http
  var Link:LayoutPrototype p :> l first
  while exists:p
    p html a http
    p :> p next


method p html a http
  oarg_rw LayoutPara p ; arg Address a ; arg_rw Stream http
  if (p:flags .and. 20h)<>0
    http writechars "<center><h1>"
  eif (p:flags .and. 10h)<>0
    http writechars "<h2>"
  eif (p:flags .and. 3)=0
    http writeline "<div>"
  else
    http writeline "<p>"
  p recurse_html a http
  if (p:flags .and. 20h)<>0
    http writechars "</h1></center>"
  if (p:flags .and. 10h)<>0
    http writechars "</h2>"
    http writeline "</h2>"
  eif (p:flags .and. 3)=0
    http writeline "</div>"
  else
    http writeline "</p>"

method t html a http
  oarg_rw LayoutText t ; arg Address a ; arg_rw Stream http
  http writechars (html_encode t:text true)
  var Pointer:ConsoleHttpProxyContext c :> a map ConsoleHttpProxyContext
  var Str txt := html_encode t:text true
  while { var Int i := txt search "  " -1 ; i<>(-1) }
    var Int j := i+2
    while j<txt:len and txt:j="  "
      j += 1
    txt := (txt 0 i)+(repeat j-i "&nbsp;")+(txt j txt:len)
  http writechars txt

method l html a http
  oarg_rw LayoutLink l ; arg Address a ; arg_rw Stream http
  http writechars "<a href=[dq][dq]>"+(html_encode l:label true)+"</a>"
  

method s html a http
  oarg_rw LayoutSequence s ; arg Address a ; arg_rw Stream http
  s recurse_html a http

method s html a http
  oarg_rw LayoutSection s ; arg Address a ; arg_rw Stream http
  s set_sent
  http writeline "<span id=[dq]"+(http_encode s:section)+"[dq]>"
  s recurse_html a http
  http writeline "</span>"


method b html a http
  oarg_rw LayoutButton b ; arg Address a ; arg_rw Stream http
  var Pointer:ConsoleHttpProxyContext c :> a map ConsoleHttpProxyContext
  http writeline "<input type=[dq]button[dq] value=[dq]"+(html_encode b:label)+"[dq] onclick=[dq]location.replace('/run/"+c:secret+"/"+(http_encode b:id)+"')[dq]>"
  if (b:flags .and. 8)<>0
    http writechars "<span style=[dq]color: #0000C0;[dq] onclick=[dq]run('"+(http_encode b:id)+"')[dq]>"+(html_encode b:label true)+"</span>"
  else
    var Pointer:ConsoleHttpProxyContext c :> a map ConsoleHttpProxyContext
    http writechars "<input type=[dq]button[dq] value=[dq]"+(html_encode b:label)+"[dq] onclick=[dq]run('"+(http_encode b:id)+"')[dq]"
    if css
      http writechars " class=[dq]button[dq]"
    if (b:flags .and. 1)<>0
      http writechars " onmouseover=[dq]overon('"+(http_encode b:id)+"')[dq]"
      http writechars " onmouseout=[dq]overoff('"+(http_encode b:id)+"')[dq]"
    http writeline ">"

method i html a http
  oarg_rw LayoutInput i ; arg Address a ; arg_rw Stream http
  if (i:flags .and. 4)<>0
    http writeline "<textarea[dq] name=[dq]"+(http_encode i:id)+"[dq] onChange=[dq]change(this)[dq]>"+(html_encode i:value)+"</textarea>"
    var Int nx := 1 ; var Int ny := 1
    var Str32 v := utf8_decode i:value
    var Int i1 := 0
    while i1<v:len
      var Int i2 := ((v i1 v:len) search "[lf]" v:len-i1)+i1
      nx := max nx i2-i1
      if i2<v:len
        ny += 1
      i1 := i2+1
    http writeline "<textarea[dq] name=[dq]"+(http_encode i:id)+"[dq] cols=[dq]"+string:nx+"[dq] rows=[dq]"+string:ny+"[dq] onChange=[dq]change(this)[dq] onKeyup=[dq]adjust2(this)[dq]>"+(html_encode i:value)+"</textarea>"
  else
    http writeline "<input type=[dq]text[dq] name=[dq]"+(http_encode i:id)+"[dq] value=[dq]"+i:value+"[dq] onChange=[dq]change(this)[dq]>"
    http writechars "<input type=[dq]text[dq] name=[dq]"+(http_encode i:id)+"[dq] value=[dq]"+i:value+"[dq] size=[dq]"+string:(max (utf8_decode i:value):len 1)+"[dq] onChange=[dq]change(this)[dq] onKeyup=[dq]adjust(this)[dq]"
    if (i:flags .and. 1)<>0
      http writechars " onmouseover=[dq]overon('"+(http_encode i:id)+"')[dq]"
      http writechars " onmouseout=[dq]overoff('"+(http_encode i:id)+"')[dq]"
    http writeline ">"

method s html a http
  oarg_rw LayoutSelect s ; arg Address a ; arg_rw Stream http
  http writeline "<select name=[dq]"+(http_encode s:id)+"[dq] onChange=[dq]change(this)[dq]>"
  if css and gecko1
    http writechars "<span class=[dq]bug[dq]>"
  http writechars "<select name=[dq]"+(http_encode s:id)+"[dq] onChange=[dq]change(this)[dq]"
  if (s:flags .and. 1)<>0
    http writechars " onmouseover=[dq]overon('"+(http_encode s:id)+"')[dq]"
    http writechars " onmouseout=[dq]overoff('"+(http_encode s:id)+"')[dq]"
  http writeline ">"
  each o s:options
    http writeline "<option"+(shunt s:value=o:value " selected" "")+" value=[dq]"+o:value+"[dq]>"+o:label+"</option>"
  http writeline "</select>"
  http writechars "</select>"
  if css and gecko1
    http writeline "</span>"


method t html a http
  oarg_rw LayoutTable t ; arg Address a ; arg_rw Stream http
  http writeline "<table border=[dq]1[dq] cellspacing=[dq]0[dq]>"
  var Pointer:ConsoleHttpProxyContext c :> a map ConsoleHttpProxyContext
  http writeline "<table border=[dq]"+(string 2*c:style:table:cell:r2:x0*72/25.4 "fixed 0")+"[dq] cellspacing=[dq]0[dq]>"
  t recurse_html a http
  http writeline "</table>"

method r html a http
  oarg_rw LayoutRow r ; arg Address a ; arg_rw Stream http
  http writeline "<tr>"
  r recurse_html a http
  http writeline "</tr>"

method c html a http
  oarg_rw LayoutCell c ; arg Address a ; arg_rw Stream http
  http writeline "<td>"
  c recurse_html a http
method cell html a http
  oarg_rw LayoutCell cell ; arg Address a ; arg_rw Stream http
  var Pointer:ConsoleHttpProxyContext c :> a map ConsoleHttpProxyContext
  var Pointer:LayoutColor bg :> c:style:table:cell:r2 color
  if cell:header
    bg :> c:style:table:header:r2:color
  if (exists bg:gamut)
    http writeline "<td bgcolor=[dq]"+(string (c color bg) "html")+"[dq]>"
  else
    http writeline "<td>"
  cell recurse_html a http
  http writeline "</td>"


method r html a http
  oarg_rw LayoutRestyle r ; arg Address a ; arg_rw Stream http
  r recurse_html a http
method s html a http
  oarg_rw LayoutRestyle s ; arg Address a ; arg_rw Stream http
  var Pointer:ConsoleHttpProxyContext c :> a map ConsoleHttpProxyContext
  var Pointer:LayoutStyle memo :> c style
  var Float size1 := memo:standard:text size
  var CBool colored := exists memo:standard:text:color:gamut
  if colored
    var ColorRGB888 rgb1 := c color memo:standard:text:color
  var CBool bold := memo:standard:text bold
  var CBool italic := memo:standard:text italic
  var CBool fixed := memo:standard:text fixed
  if (exists s:style)
    c style :> s style
  each attr s:attributes
    memory_swap ((addressof c:style) translate Byte attr:offset) attr:value attr:size
  if (exists c:style:standard:text:color:gamut)
    var ColorRGB888 rgb2 := c color c:style:standard:text:color
  var Float size2 := c:style:standard:text size
  colored := (exists c:style:standard:text:color:gamut) and (not colored or (string rgb2 "html")<>(string rgb1 "html"))
  bold := not bold and c:style:standard:text:bold
  italic := not italic and c:style:standard:text:italic
  fixed := not italic and c:style:standard:text:fixed
  if size2<>size1
    http writeline "<span style=[dq]font-size: "+(string size2*72/25.4 "fixed 0")+"pt;[dq]>"
  if colored
    http writeline "<span style=[dq]color: "+(string rgb2 "html")+";[dq]>"
  if fixed
    http writeline "<tt>"
  if bold
    http writeline "<b>"
  if italic
    http writeline "<i>"
  s recurse_html a http
  if italic
    http writeline "</i>"
  if bold
    http writeline "</b>"
  if fixed
    http writeline "</tt>"
  if colored
    http writeline "</span>"
  if size2<>size1
    http writeline "</span>"
  each attr s:attributes
    memory_swap ((addressof c:style) translate Byte attr:offset) attr:value attr:size
  c style :> memo

method h html a http
  oarg_rw LayoutHook h ; arg Address a ; arg_rw Stream http
  h recurse_html a http
  if false # (h:flags .and. 2^24) # ssr
     void
  else
    h recurse_html a http


method i html a http
  oarg_rw LayoutImage i ; arg Address a ; arg_rw Stream http
  var Pointer:ConsoleHttpProxyContext c :> a map ConsoleHttpProxyContext
  http writeline "<img src=[dq]"+url_header+"/image/"+(http_encode c:secret)+"/"+http_encode:(i:image:options option "id" Str)+"[dq]>"

method d html a http
  oarg_rw LayoutDraw d ; arg Address a ; arg_rw Stream http


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


method l set id value
  oarg_rw LayoutPrototype l ; arg Str id value
method l set id value -> active
  oarg_rw LayoutPrototype l ; arg Str id value ; arg CBool active
  active := false
  var Pointer:Type t :> entry_type addressof:l
  if t=LayoutInput
    if (addressof:l map LayoutInput):id=id
      (addressof:l map LayoutInput) value := value
    active := ((addressof:l map LayoutInput):flags .and. 16)<>0
  eif t=LayoutSelect
    if (addressof:l map LayoutSelect):id=id
      (addressof:l map LayoutSelect) value := value
    active := ((addressof:l map LayoutSelect):flags .and. 16)<>0
  else
    var Link:LayoutPrototype p :> l first
    while exists:p
      p set id value
      if (p set id value)
        active := true
      p :> p next


gvar (Dictionary Str ConsoleHttpProxyContext) http_proxy_sessions
function what_browser identity browser_model browser_release
  arg Str identity ; arg_w Str browser_model ; arg_w Float browser_release
  var Str id := lower identity
  if (id parse word:"pliant" "/" browser_release any)
    browser_model := "pliant"
  eif (id parse any word:"opera" "/" browser_release any) or (id parse any word:"opera" browser_release any)
    browser_model := "opera"
  eif (id parse any word:"msie" browser_release any)
    browser_model := "ie"
  eif (id parse any word:"konqueror" "/" browser_release any) or (id parse any word:"safari" "/" browser_release any)
    browser_model := "konqueror"
  eif (id parse word:"mozilla" "/" browser_release any)
    browser_model := shunt browser_release<5 "netscape" "mozilla"
  else
    browser_model := "" ; browser_release := undefined


method ch service http
  arg_rw ConsoleHttpProxy ch ; arg_rw Stream http
  if (http safe_query "remote_ip_address")<>"127.0.0.1" # we don't handle security in this toy version, so let's be a bit restrictive
    return
  var Str cmd := http readline
  if not (cmd eparse any:(var Str command) _ any:(var Str path) _ any:(var Str protocol))
    return
  var Int length := 0
  while { var Str param := http readline ; param<>"" }
    if (param parse any:(var Str tag) ":" any:(var Str value))
      tag := lower tag
      if tag="content-length"
        if (value parse (var Int i)) and i>=0 and i<2^20
          length := i
  (var Str form) set (memory_allocate length null) length true
  http raw_read form:characters length
  # console "http " command " " path eol
  # console "form is " form eol
  var Pointer:ConsoleHttpProxyContext c
  if command="GET" and (path eparse "/run/" any:(var Str secret) "/" any:(var Str id))
    c :> http_proxy_sessions first secret
    if not exists:c
      # console "no such session " secret eol
      http writeline "HTTP/"+protocol+" 404 Session closed"
      http writeline ""
      return
    c:console lazy_display_mark := false
    var Pointer:BrowserSession s :> c:console:session 0
    s:connection otag "run" http_decode:id
    s:connection flush anytime
  eif command="GET" and path<>"/favicon.ico"
    constant dpi 75
    c :> var ConsoleHttpProxyContext new_console
    c console :> new BrowserConsole
    var Link:LayoutStyle st :> new LayoutStyle
    st reset
    st:input border_size := 25.4/dpi
    st:table border_size := 25.4/dpi
    c:console default_style :> st
    c:console size_x := cast 210*dpi/25.4 Int
    c:console size_y := cast 297*dpi/24.4 Int
    c:console gamut :> color_gamut "rgb"
    c secret := string (random 2n^128)
    var Pointer:BrowserSession s :> c:console:session 0
    s connect_main ch:root_url+path (var Dictionary empty_context)
    http_proxy_sessions insert c:secret c
  eif command="POST" and (path  eparse "/set/" any:(var Str secret) "/" any:(var Str id))
    c :> http_proxy_sessions first secret
    if not exists:c
      # console "no such session " secret eol
      http writeline "HTTP/"+protocol+" 404 Session closed"
      http writeline ""
      return
    var Pointer:BrowserSession s :> c:console:session 0
    each w s:windows
      if (exists w:root)
        w:root set http_decode:id form
    s:connection otag "set" http_decode:id form
    s:connection flush anytime
    http writeline "HTTP/"+protocol+" 200 OK"
    http writeline ""
    return
function javascript http secret browser_model browser_release
  arg_rw Stream http ; arg Str secret browser_model ; arg Float browser_release

  http writeline "var http_request;"
  http writeline "var alive_request;"
  http writeline "var alive_timer;"
  http writeline "var alive_sleep = 1;"
  http writeline "var over_request;"
  http writeline "var over_cmd = '';"
  http writeline "var over_id;"

  http writeline "function apply(p) {"
  http writeline "  m0 = -1;"
  http writeline "  while (true) {"
  http writeline "    m1 = p.indexOf('"+character:1+"',m0+1);"
  http writeline "    if (m1 == -1) {"
  if frame
    http writeline "      if (m0 > 0) { frameadjust(); }"
  http writeline "      return false;"
  http writeline "    }"
  http writeline "    m2 = p.indexOf('"+character:2+"',m1+1);"
  http writeline "    if (m2 == -1) {"
  http writeline "      return false;"
  http writeline "    }"
  if frame
    http writeline "    try {"
    http writeline "      top.wtop.document.getElementById(p.substr(m0+1,m1-m0-1)).innerHTML = p.substr(m1+1,m2-m1-1);"
    http writeline "    } catch(e) {}"
    http writeline "    try {"
    http writeline "      top.wleft.document.getElementById(p.substr(m0+1,m1-m0-1)).innerHTML = p.substr(m1+1,m2-m1-1);"
    http writeline "    } catch(e) {}"
    http writeline "    try {"
    http writeline "      top.wmain.document.getElementById(p.substr(m0+1,m1-m0-1)).innerHTML = p.substr(m1+1,m2-m1-1);"
    http writeline "    } catch(e) {}"
    http writeline "    try {"
    http writeline "      top.wbottom.document.getElementById(p.substr(m0+1,m1-m0-1)).innerHTML = p.substr(m1+1,m2-m1-1);"
    http writeline "    } catch(e) {}"
  else
    # console "unsupported request" eol
    http writeline "HTTP/"+protocol+" 404 NOT FOUND"
    http writeline ""
    return
  http writeline "HTTP/"+protocol+" 200 OK"
  http writeline "Content-Type: text/html; charset=UTF8"
  http writeline ""
  http writeline "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2 Final//EN[dq]>"
  http writeline "<html>"
  http writeline "<script language=[dq]JavaScript[dq]>"
  http writeline "var  http_request;"
    http writeline "      document.getElementById(p.substr(m0+1,m1-m0-1)).innerHTML = p.substr(m1+1,m2-m1-1);"
  http writeline "    m0 = m2"
  http writeline "    alive_sleep = "+string:http_proxy_alive_mini
  http writeline "  }"
  http writeline "}"

  http writeline "function change(f) {"
  http writeline "  http_request = false;"
  http writeline "  if (window.XMLHttpRequest) { // Gecko"
  http writeline "    http_request = new XMLHttpRequest();"
  http writeline "  } else if (window.ActiveXObject) { // IE"
  http writeline "    http_request = new ActiveXObject('Microsoft.XMLHTTP');"
  if browser_model="ie"
    http writeline "  change_request = new ActiveXObject('Microsoft.XMLHTTP');"
  else
    http writeline "  change_request = new XMLHttpRequest();"
  http writeline "  if (!change_request) {"
  http writeline "    clearTimeout(alive_timer);"
  http writeline "    alert('Unsupported "+browser_model+" "+string:browser_release+" web ui');"
  http writeline "    return false;"
  http writeline "  }"
  http writeline "  if (!http_request) {"
  http writeline "    alert('Unsupported web browser');"
  http writeline "  change_request.onreadystatechange = change_result;"
  http writeline "  change_request.open('POST', '"+url_header+"/set/"+secret+"/'+f.name, true);"
  http writeline "  change_request.send(f.value);"
  http writeline "}"

  http writeline "function change_result() {"
  http writeline "  if (change_request.readyState == 4) {"
  http writeline "    try {"
  http writeline "      if (change_request.status != 200) {"
  http writeline "        clearTimeout(alive_timer);"
  http writeline "        alert('Session is closed');"
  http writeline "      } else {"
  http writeline "        apply(change_request.responseText);"
  http writeline "      }"
  http writeline "    } catch(e) {"
  http writeline "      clearTimeout(alive_timer);"
  http writeline "      alert('Server seems to be down');"
  http writeline "    }"
  http writeline "  }"
  http writeline "}"

  http writeline "function overrequest(cmd,id) {"
  if browser_model="ie"
    http writeline "  over_request = new ActiveXObject('Microsoft.XMLHTTP');"
  else
    http writeline "  over_request = new XMLHttpRequest();"
  http writeline "  if (over_request) {"
  http writeline "    over_request.onreadystatechange = over_result;"
  http writeline "    over_request.open('GET', '"+url_header+"/over/'+cmd+'/"+secret+"/'+id, true);"
  http writeline "    over_request.send('');"
  http writeline "  }"
  http writeline "}"

  http writeline "function over_result() {"
  http writeline "  if (over_request.readyState == 4) {"
  http writeline "    try {"
  http writeline "      if (over_request.status == 200) {"
  http writeline "        apply(over_request.responseText);"
  http writeline "      }"
  http writeline "    } catch(e) {}"
  http writeline "    if (over_cmd != '') {"
  http writeline "      cmd = over_cmd;"
  http writeline "      id = over_id;"
  http writeline "      over_cmd = '';"
  http writeline "      overrequest(cmd,id);"
  http writeline "    } else {"
  http writeline "      over_request = false;"
  http writeline "    }"
  http writeline "  }"
  http writeline "}"

  http writeline "function overon(id) {"
  http writeline "  if (over_request) {"
  http writeline "    over_cmd = 'on'"
  http writeline "    over_id = id"
  http writeline "  } else {"
  http writeline "    overrequest('on',id);"
  http writeline "  }"
  http writeline "}"

  http writeline "function overoff(id) {"
  http writeline "  if (over_request) {"
  http writeline "    over_cmd = 'off'"
  http writeline "    over_id = id"
  http writeline "  } else {"
  http writeline "    overrequest('off',id);"
  http writeline "  }"
  http writeline "}"

  http writeline "function adjust(f) {"
  http writeline "  f.setAttribute('size',Math.max(f.value.length,1));"
  http writeline "}"

  http writeline "function adjust2(f) {"
  http writeline "  nx = 1;"
  http writeline "  ny = 1;"
  http writeline "  i1 = 0;"
  http writeline "  while (i1 < f.value.length) {"
  http writeline "    i2 = f.value.indexOf('\n',i1);"
  http writeline "    if (i2 == -1) { i2 = f.value.length; }"
  http writeline "    nx = Math.max(nx,i2-i1);"
  http writeline "    if (i2 < f.value.length) { ny = ny+1; }"
  http writeline "    i1 = i2+1;"
  http writeline "  }"
  http writeline "  f.setAttribute('cols',nx);"
  http writeline "  f.setAttribute('rows',ny);"
  http writeline "}"

  http writeline "function run(id) {"
  var Str scrolling
  if browser_model="ie"
    scrolling := "+'/'+document.body.scrollLeft+'/'+document.body.scrollTop"
  else
    scrolling := "+'/'+"+(shunt frame "top.wmain." "window.")+"pageXOffset+'/'+"+(shunt frame "top.wmain." "window.")+"pageYOffset"
  http writeline "  "+(shunt frame "top." "")+"location.replace('"+url_header+"/run/"+secret+"/'+id"+scrolling+");"
  http writeline "}"

  http writeline "function alive() {"
  if browser_model="ie"
    http writeline "  http_request = new ActiveXObject('Microsoft.XMLHTTP');"
  else
    http writeline "  alive_request = new XMLHttpRequest();"
  http writeline "  if (!alive_request) {"
  http writeline "    alert('Unsupported "+browser_model+" "+string:browser_release+" web ui');"
  http writeline "    return false;"
  http writeline "  }"
  http writeline "  http_request.onreadystatechange = result;"
  http writeline "  http_request.open('POST', '/set/"+c:secret+"/'+f.name, true);"
  http writeline "  http_request.send(f.value);"
  http writeline "  alive_request.onreadystatechange = alive_result;"
  http writeline "  alive_request.open('GET', '"+url_header+"/alive/"+secret+"', true);"
  http writeline "  alive_request.send('');"
  http writeline "}"
  http writeline "function result() {"
  http writeline "  if (http_request.readyState == 4) {"

  http writeline "function alive_result() {"
  http writeline "  if (alive_request.readyState == 4) {"
  http writeline "    try {"
  http writeline "      if (http_request.status != 200) {"
  http writeline "      if (alive_request.status != 200) {"
  http writeline "        alert('Session is closed');"
  http writeline "      } else {"
  http writeline "        alive_sleep = Math.min(alive_sleep*2,"+string:http_proxy_alive_maxi+");"
  http writeline "        apply(alive_request.responseText);"
  http writeline "        alive_timer = setTimeout('alive()',alive_sleep*1000);"
  http writeline "      }"
  http writeline "    } catch(e) {"
  http writeline "      alert('Server seems to be down');"
  http writeline "    }"
  http writeline "  }"
  http writeline "}"
  http writeline "</script>"
  http writeline "<head>"
  http writeline "</head>"
  http writeline "<body>"
  http writeline "<form name=[dq]pliant[dq] method=[dq]POST[dq]>"
  while not c:console:lazy_display_mark

  if frame
    http writeline "function frameadjust() {"
    constant enlarge 12
    constant minimal string:(shunt rounded 2*rounded_size+3 1)
    http writeline "  dtop = top.wtop.document.getElementById('rtop').clientHeight;"
    http writeline "  if (dtop > "+minimal+") {"
    http writeline "    top.document.getElementById('tframe').setAttribute('rows',(dtop+"+string:enlarge+")+',*');"
    if not rounded
      http writeline "    top.document.getElementById('tframe').setAttribute('frameborder','1');"
    http writeline "  } else {"
    http writeline "    top.document.getElementById('tframe').setAttribute('rows','0,*');"
    if not rounded
      http writeline "    top.document.getElementById('tframe').setAttribute('frameborder','0');"
    http writeline "  }"
    http writeline "  dleft = top.wleft.document.getElementById('rleft').clientWidth;"
    http writeline "  if (dleft > "+minimal+") {"
    http writeline "    top.document.getElementById('lframe').setAttribute('cols',(dleft+"+string:enlarge+")+',*');"
    if not rounded
      http writeline "    top.document.getElementById('lframe').setAttribute('frameborder','1');"
    http writeline "  } else {"
    http writeline "    top.document.getElementById('lframe').setAttribute('cols','0,*');"
    if not rounded
      http writeline "    top.document.getElementById('lframe').setAttribute('frameborder','0');"
    http writeline "  }"
    http writeline "  dbottom = top.wbottom.document.getElementById('rbottom').clientHeight;"
    http writeline "  if (dbottom > "+minimal+") {"
    http writeline "    top.document.getElementById('bframe').setAttribute('rows','*,'+(dbottom+"+string:enlarge+"));"
    if not rounded
      http writeline "    top.document.getElementById('bframe').setAttribute('frameborder','1');"
    http writeline "  } else {"
    http writeline "    top.document.getElementById('bframe').setAttribute('rows','*,0');"
    if not rounded
      http writeline "    top.document.getElementById('bframe').setAttribute('frameborder','0');"
    http writeline "  }"
    http writeline "}"


function css http
  arg_rw Stream http
  http writeline "body { font-family: sans-serif; }"
  if css
    http writeline "input.button { background-color: #D0D0D0;  font-weight: bold; font-size: 14px; color: #000040; border: 1px solid #808080; -moz-border-radius: 3px ; margin: 2px; }"
    http writeline "input { background-color: #FFFFE0; border: 1px solid #808080; -moz-border-radius: 3px; }"
    if gecko1
      http writeline "select { background-color: #FFFFE0; border: 0px solid transparent; }"
      http writeline "span.bug { padding: 3px; border: 1px solid #808080; -moz-border-radius: 3px; }"
    else
      http writeline "select { background-color: #FFFFE0; border: 1px solid #808080; -moz-border-radius: 3px; }"
    http writeline "textarea { background-color: #FFFFE0; border: 1px solid #808080; -moz-border-radius: 3px; }"


function setup_http_encoding http compress answer
  arg_rw Stream http ; arg Str compress ; arg_w Link:Stream answer
  answer :> http
  if true
    http writeline "Transfer-Encoding: chunked"
    var Link:Stream chunked :> new Stream
    chunked open "chunked:" "" out+safe pliant_default_file_system answer
    answer :> chunked
  if compress<>""
    http writeline "Content-Encoding: "+compress
    var Link:Stream compressed :> new Stream
    compressed open compress+":" "" out+safe pliant_default_file_system answer
    answer :> compressed


method c synchronize
  arg_rw ConsoleHttpProxyContext c
  while not c:console:lazy_display_flag
    sleep 0
  var Pointer:BrowserSession s :> c:console:session 0


function send_error http code message extra
  arg_rw Stream http ; arg Int code ; arg Str message extra
  http writeline "HTTP/1.1 "+string:code+" "+message
  http writechars extra
  http writeline "Content-Length: 0"
  http writeline ""


function start_answer http extra compress answer
  arg_rw Stream http ; arg Str extra compress ; arg_w Link:Stream answer
  http writeline "HTTP/1.1 200 OK"
  http writechars extra
  setup_http_encoding http compress answer
  http writeline ""


method c send_content http window site compress
  arg_rw ConsoleHttpProxyContext c ; arg_rw Stream http ; arg Str window site compress
  var Pointer:UISession s :> c:console:session 0
  if s:rejected
    send_error http 401 "Unauthorized" "WWW-Authenticate: Basic realm=[dq]"+site+"[dq][lf]"
    s rejected := false
    return
  var Link:LayoutPrototype top :> (s window "top") root 
  var Link:LayoutPrototype left :> (s window "left") root 
  var Link:LayoutPrototype right :> (s window "right") root 
  var Link:LayoutPrototype bottom :> (s window "bottom") root 
  var Link:LayoutPrototype main :> (s window "main") root
  if exists:top or exists:left or exists:right or exists:bottom
    var Int nc := (shunt exists:left 1 0)+1+(shunt exists:right 1 0)
    http writeline "<table border=[dq]1[dq] cellspacing=[dq]0[dq]>"
    if exists:top
      http writeline "<tr>"
      http writeline "<td"+(shunt nc<>1 " colspan=[dq]"+string:nc+"[dq]" "")+">"
      top html addressof:c http
      http writeline "</td>"
      http writeline "</tr>"
    http writeline "<tr>"
    if exists:left
      http writeline "<td>"
      left html addressof:c http
      http writeline "</td>"
    http writeline "<td>"
    if exists:main
      main html addressof:c http
    http writeline "</td>"
    if exists:right
      http writeline "<td>"
      right html addressof:c http
      http writeline "</td>"
    http writeline "</tr>"
    if exists:bottom
      http writeline "<tr>"
      http writeline "<td"+(shunt nc<>1 " colspan=[dq]"+string:nc+"[dq]" "")+">"
      bottom html addressof:c http
      http writeline "</td>"
      http writeline "</tr>"
    http writeline "</table>"
  eif exists:main
    main html addressof:c http
  http writeline "</form>"
  http writeline "</body>"
  http writeline "</html>"
  # console "done" eol
  start_answer http "Content-Type: text/html; charset=UTF8[lf]" compress (var Link:Stream answer)
  answer writeline "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2 Final//EN[dq]>"
  answer writeline "<html>"
  answer writeline "<head>"
  answer writeline "<script src=[dq]"+url_header+"/javascript/"+c:secret+"/pliant.js[dq] language=[dq]JavaScript[dq]></script>"
  answer writeline "<style type=[dq]text/css[dq]>"
  css answer
  answer writeline "</style>"
  answer writeline "</head>"
  if frame and window=""
    constant frameborder (shunt rounded " frameborder=[dq]0[dq]" "")
    constant scrolling (shunt rounded " scrolling=[dq]no[dq]" "")
    answer writeline "<frameset rows=[dq]100,*[dq] id=[dq]tframe[dq] onLoad=[dq]frameadjust()[dq]"+frameborder+">"
    answer writeline "<frame name=[dq]wtop[dq] src=[dq]"+url_header+"/frame/"+c:secret+"/top[dq]"+scrolling+">"
    answer writeline "<frameset rows=[dq]*,100[dq] id=[dq]bframe[dq]"+frameborder+">"
    answer writeline "<frameset cols=[dq]100,*[dq] id=[dq]lframe[dq]"+frameborder+">"
    answer writeline "<frame name=[dq]wleft[dq] src=[dq]"+url_header+"/frame/"+c:secret+"/left[dq]"+scrolling+">"
    answer writeline "<frame name=[dq]wmain[dq] src=[dq]"+url_header+"/frame/"+c:secret+"/main[dq]>"
    answer writeline "</frameset>"
    answer writeline "<frame name=[dq]wbottom[dq] src=[dq]"+url_header+"/frame/"+c:secret+"/bottom[dq]"+scrolling+">"
    answer writeline "</frameset>"
    answer writeline "</frameset>"
  else
    answer writeline "<body>"
    answer writeline "<form name=[dq]pliant[dq] method=[dq]POST[dq]>"
    if frame and window<>"" and window<>"main"
      var Str stretch := shunt rounded and window="left" "height" "width"
      var Str align := shunt rounded and window="left" " valign=[dq]top[dq]" ""
      answer writeline "<table border=[dq]0[dq] cellpadding=[dq]0[dq] cellspacing=[dq]0[dq] id=[dq]r"+window+"[dq] "+stretch+"=[dq]99%[dq]><tr><td"+align+">"
      if rounded
        answer writeline "<div style=[dq]"+stretch+": 99%; background: "+(string rounded_ground_color "html")+"; padding: "+string:rounded_size+"px; border-color: "+(string rounded_border_color "html")+"; border-width: 1px; border-style: solid; -moz-border-radius: "+string:rounded_size+"px[dq]>"
    if not frame and (exists:top or exists:left or exists:right or exists:bottom)
      var Int nc := (shunt exists:left 1 0)+1+(shunt exists:right 1 0)
      answer writeline "<table border=[dq]1[dq] cellspacing=[dq]0[dq]>"
      if exists:top
        answer writeline "<tr>"
        answer writeline "<td"+(shunt nc<>1 " colspan=[dq]"+string:nc+"[dq]" "")+">"
        top html addressof:c answer
        answer writeline "</td>"
        answer writeline "</tr>"
      answer writeline "<tr>"
      if exists:left
        answer writeline "<td valign=[dq]top[dq]>"
        left html addressof:c answer
        answer writeline "</td>"
      answer writeline "<td>"
      if exists:main
        main html addressof:c answer
      answer writeline "</td>"
      if exists:right
        answer writeline "<td valign=[dq]top[dq]>"
        right html addressof:c answer
        answer writeline "</td>"
      answer writeline "</tr>"
      if exists:bottom
        answer writeline "<tr>"
        answer writeline "<td"+(shunt nc<>1 " colspan=[dq]"+string:nc+"[dq]" "")+">"
        bottom html addressof:c answer
        answer writeline "</td>"
        answer writeline "</tr>"
      answer writeline "</table>"
    eif frame and window<>""
      var Pointer:UIWindow w :> s window window
      if exists:w and (exists w:root)
        w:root html addressof:c answer
    eif exists:main
      main html addressof:c answer
    if frame and window<>"" and window<>"main"
      if rounded
        answer writeline "</div>"
      answer writeline "</td></tr></table>"
    answer writeline "</form>"
    if not frame or window="main"
      answer writeline "<script language=[dq]JavaScript[dq]>"
      var Pointer:UIWindow w :> s window "main"
      if w:scroll_x<>0 or w:scroll_y<>0
        answer writeline "window.scrollTo("+(string w:scroll_x)+","+(string w:scroll_y)+");"
      answer writeline "alive_timer = setTimeout('alive()',"+(string http_proxy_alive_mini*1000)+");"
      answer writeline "</script>"
    if alt
      answer writeline "<script language=[dq]JavaScript[dq]>"
      answer writeline "function alt(e) {"
      answer writeline "  if (e.altKey) {"
      answer writeline "    alert('Alt '+e.which);"
      answer writeline "  }"
      answer writeline "}"
      answer writeline "document.captureEvents(Event.KeyDown);"
      answer writeline "document.onKeyDown = alt;"
      answer writeline "</script>"
    answer writeline "</body>"
  answer writeline "</html>"
  answer :> null map Stream


method c upgrade l http
  arg_rw ConsoleHttpProxyContext c ; oarg_rw LayoutPrototype l ; arg_rw Stream http
  if l:positioned
    return
  l set_position
  if (entry_type addressof:l)=LayoutSection and not l:sent
    var Pointer:LayoutSection s :> addressof:l map LayoutSection
    http writechars s:section+character:1
    l html addressof:c http
    http writechars character:2
    return
  var Link:LayoutPrototype p :> l first
  while exists:p
    c upgrade p http
    p :> p next


method ch service http
  arg_rw ConsoleHttpProxy ch ; arg_rw Stream http
  if trace
    console "new HTTP proxy connection" eol
  while not http:atend
    var Str cmd := http readline
    if trace
      console cmd eol
    if not (cmd eparse any:(var Str command) _ any:(var Str path) _ any:(var Str protocol))
      return
    var Str site
    var Int length := 0
    var Str user password
    var Str browser_model := "" ; var Float browser_release := undefined
    var Str compress := ""
    while { var Str param := http readline ; param<>"" }
      if (param parse any:(var Str tag) ":" any:(var Str value))
        tag := lower tag
        if tag="host"
          site := value 0 (value search ":" value:len)
        eif tag="content-length"
          if (value parse (var Int i)) and i>=0 and i<2^20
            length := i
        eif tag="user-agent"
          what_browser value browser_model browser_release
        eif tag="authorization"
          if (value parse acword:"basic" any:(var Str encoded))
            var Str auth := base64_decode encoded
            (auth parse any "\" any:user ":" any:password) or (auth parse any:user ":" any:password)
        eif tag="accept-encoding"
          compress := shunt (value parse any acword:"deflate" any) "deflate" (value parse any acword:"zlib" any) "zlib" (value parse any acword:"gzip" any) "gzip" ""
    if length>form_size_limit
      return
    (var Str form) set (memory_allocate length null) length true
    http raw_read form:characters length
    var Link:ConsoleHttpProxyContext c
    if command="GET" and (path eparse (pattern url_header+"/javascript/") any:(var Str secret) "/" any)
      start_answer http "Content-Type: application/x-javascript[lf]Cache-Control: max-age=86400[lf]" compress (var Link:Stream answer)
      javascript answer secret browser_model browser_release
      answer :> null map Stream
    eif command="GET" and (path  eparse (pattern url_header+"/alive/") any:(var Str secret))
      if not (cache_search cache_header+secret ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype))
        send_error http 404 "Session closed" ""
      else
        if gather_infos
          c alive := datetime
          # console "alive " secret " at " c:alive " since " c:since eol
        start_answer http "" compress (var Link:Stream answer)
        c:console:sem request
        var Pointer:UISession s :> c:console:session 0
        each w s:windows
          if (exists w:root)
            c upgrade w:root answer
        c:console:sem release
        answer :> null map Stream
    eif command="POST" and (path  eparse (pattern url_header+"/set/") any:(var Str secret) "/" any:(var Str id))
      if not (cache_search cache_header+secret ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype))
        send_error http 404 "Session closed" ""
      else
        c:console:sem request
        var CBool active := false
        var Pointer:UISession s :> c:console:session 0
        each w s:windows
          if (exists w:root)
            if (w:root set http_decode:id form)
              active := true
        s:connection otag "set" http_decode:id form
        if active
          c:console ack_flag := false
          s:connection otag "ack"
        s:connection flush anytime
        c:console:sem release
        if active
          start_answer http "" compress (var Link:Stream answer)
          while not c:console:ack_flag
            sleep 0
          c:console:sem request
          each w s:windows
            if (exists w:root)
              c upgrade w:root answer
          c:console:sem release
          answer :> null map Stream
        else
          send_error http 200 "OK" ""
    eif command="GET" and (path  eparse (pattern url_header+"/over/") any:(var Str mode) "/" any:(var Str secret) "/" any:(var Str id))
      # console "over " mode " " id eol
      if not (cache_search cache_header+secret ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype))
        send_error http 404 "Session closed" ""
      else
        c:console:sem request
        var Pointer:UISession s :> c:console:session 0
        s:connection otag "over" http_decode:id mode="on"
        c:console ack_flag := false
        s:connection otag "ack"
        s:connection flush anytime
        c:console:sem release
        start_answer http "" compress (var Link:Stream answer)
        while not c:console:ack_flag
          sleep 0
        c:console:sem request
        each w s:windows
          if (exists w:root)
            c upgrade w:root answer
        c:console:sem release
        answer :> null map Stream
    eif command="GET" and (path eparse (pattern url_header+"/run/") any:(var Str secret) "/" any:(var Str id) "/" (var Int scroll_x) "/" (var Int scroll_y))
      if not (cache_search cache_header+secret ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype))
        send_error http 404 "Session closed" ""
      else
        c:console:sem request
        c:console lazy_display_flag := false
        var Pointer:UISession s :> c:console:session 0
        (s window "main") scroll_x := scroll_x
        (s window "main") scroll_y := scroll_y 
        s:connection otag "run" http_decode:id
        s:connection flush anytime
        c:console:sem release
        c synchronize
        c:console:sem request
        c send_content http "" site compress
        c:console:sem release
    eif command="GET" and (path eparse (pattern url_header+"/image/") any:(var Str secret) "/" any:(var Str id))
      if not (cache_search cache_header+secret ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype))
        send_error http 404 "Session closed" ""
      else
        c:console:sem request
        var Pointer:UISession s :> c:console:session 0
        var Link:ImagePrototype img :> (s:namespace first id) map ImagePrototype
        if exists:img and ( (entry_type addressof:img)=ImagePixmap or (entry_type addressof:img)=ImagePacked )
          start_answer http "Content-Type: image/jpeg[lf]Cache-Control: max-age=86400[lf]" "" (var Link:Stream answer)
          img save answer "filter [dq].jpeg[dq]"
          answer :> null map Stream
        else
          send_error http 404 "No such image" ""
        c:console:sem release
    eif false and command="GET" and (path eparse (pattern url_header+"/corner/") any:(var Str secret) "/" (var Int corner))
      if not (cache_search cache_header+secret ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype))
        send_error http 404 "Session closed" ""
      else
        var Link:ImagePixmap pixmap :> new ImagePixmap
        pixmap setup (image_prototype 0 0 rounded_size/75*25.4 rounded_size/75*25.4 rounded_size rounded_size color_gamut:"rgb") ""
        var Int cx := shunt (corner .and. 1)<>0 0 rounded_size-1
        var Int cy := shunt (corner .and. 2)<>0 0 rounded_size-1
        for (var Int y) 0 rounded_size-1
          for (var Int x) 0 rounded_size-1
            (pixmap pixel x y) map ColorRGB888 := shunt (x-cx)*(x-cx)+(y-cy)*(y-cy)<=(rounded_size-1)*(rounded_size-1) rounded_color (color rgb 255 255 255)
        start_answer http "Content-Type: image/png[lf]Cache-Control: max-age=86400[lf]" "" (var Link:Stream answer)
        pixmap save answer "filter [dq].png[dq]"
        answer :> null map Stream
    eif frame and command="GET" and (path eparse (pattern url_header+"/frame/") any:(var Str secret) "/" any:(var Str window) )
      if not (cache_search cache_header+secret ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype))
        send_error http 404 "Session closed" ""
      else
        c synchronize
        c:console:sem request
        c send_content http window site compress
        c:console:sem release
    eif command="GET" and path="/favicon.ico"
      send_error http 200 "OK" "Cache-Control: max-age=86400[lf]"
    eif command="GET"
      var Str secret := generate_id+base64_alt_encode:(random_string 128\8)
      if (cache_open cache_header+secret ConsoleHttpProxyContext ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype))
        c console :> new UIConsole
        var Link:LayoutStyle st :> new LayoutStyle
        st reset 25.4/dpi 25.4/dpi
        c:console default_style :> st
        c:console size_x := cast 210*dpi/25.4 Int
        c:console size_y := cast 297*dpi/24.4 Int
        c:console gamut :> color_gamut "rgb"
        c style :> st
        c gamut :> c:console gamut
        c secret := secret
        var UILogin login ; login user := user ; login password := password ; login secured := false
        c:console:login insert "" login
        if gather_infos
          c browser_model := browser_model ; c browser_release := browser_release
          c since := datetime
        cache_ready ((addressof Link:ConsoleHttpProxyContext c) map Link:CachePrototype)
        c:console:sem request
        var Pointer:UISession s :> c:console:session 0
        s connect_main ch:protocol+"://"+site+path (var Dictionary empty_context)
        c:console:sem release
        c synchronize
        c:console:sem request
        c send_content http "" site compress
        c:console:sem release
      else
        send_error http 404 "Session clash" ""
    else
      send_error http 404 "Not found" ""