Patch title: Release 95 bulk changes
Abstract:
File: /pliant/graphic/console/http_proxy.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/util/pml/io.pli"
module "/pliant/protocol/common/tcp_server.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/color/gamut.pli"
module "/pliant/util/crypto/intn.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"

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


type ConsoleHttpProxyContext
  field Link:BrowserConsole console
  field Str secret


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


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>"
  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>"
  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)

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 recurse_html a http


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]>"

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>"
  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]>"

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]>"
  each o s:options
    http writeline "<option"+(shunt s:value=o:value " selected" "")+" value=[dq]"+o:value+"[dq]>"+o:label+"</option>"
  http writeline "</select>"


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]>"
  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
  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 h html a http
  oarg_rw LayoutHook h ; arg Address a ; arg_rw Stream http
  h recurse_html a http


method i html a http
  oarg_rw LayoutImage i ; arg Address a ; arg_rw Stream http

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
  var Pointer:Type t :> entry_type addressof:l
  if t=LayoutInput
    if (addressof:l map LayoutInput):id=id
      (addressof:l map LayoutInput) value := value
  eif t=LayoutSelect
    if (addressof:l map LayoutSelect):id=id
      (addressof:l map LayoutSelect) value := value
  else
    var Link:LayoutPrototype p :> l first
    while exists:p
      p set id value
      p :> p next


gvar (Dictionary Str ConsoleHttpProxyContext) http_proxy_sessions


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
  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 "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');"
  http writeline "  }"
  http writeline "  if (!http_request) {"
  http writeline "    alert('Unsupported web browser');"
  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 "}"
  http writeline "function result() {"
  http writeline "  if (http_request.readyState == 4) {"
  http writeline "    try {"
  http writeline "      if (http_request.status != 200) {"
  http writeline "        alert('Session is closed');"
  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
    sleep 0
  var Pointer:BrowserSession s :> c:console:session 0
  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