Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/browser/naive/server.pli
Key:
    Removed line
    Added line
# pliant 'precompile /binary/rip.dump module /pliant/graphic/image/rip.pli' module /pliant/graphic/browser/naive/sample/fullpliant.pli command browser_server

module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
submodule "/pliant/language/data/id.pli"
module "/pliant/storage/database.pli"
submodule "/pliant/protocol/common/tcp_server.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/math/vector.pli"
module "/pliant/math/curve.pli"

module "/pliant/language/context.pli"
module "/pliant/fullpliant/user.pli"
module "/pliant/admin/md5.pli"
module "/pliant/language/schedule/threads_engine.pli"
module "/pliant/language/type/text/language.pli"
module "/pliant/protocol/common/misc.pli"
module "/pliant/util/crypto/channel.pli"
module "/pliant/language/stream/filesystembase.pli"
module "tcp.pli"
module "trace.pli"


# context pre defined options:
# language = prefered language (an example could be 'fr')
# skill = user skill can be 'low' 'medium' or 'high'
# bps = connection speed
# latency = time to send or receive a packet (in seconds)
# memory = number of bytes of memory available to the browser
# frequency = browser CPU frequency in hz equivalence to i386 architecture
# screen mm_x mm_y size_x size_y = screen size and resolution
# antialiasing = default browser antialiasing


type BrowserConnection
  field Link:Stream stream
  field Str section_current
  field Str url_path url_subpath url_options
  field Str user_name
  field Int user_auth_level <- 0
  field Dictionary user_rights
  field CBool user_is_admin <- false
  field Str remote_ip_address
  field Str language
  field Str event key ; field Int buttons ; field Float x y
  field Str hook_id ; field Float hook_x0 hook_y0 hook_x1 hook_y1
  field Str target_id; field Int target_index ; field Str target_options
  field Float target_x0 target_y0 target_x1 target_y1 
  field Str focus_hook focus_id ; field Int focus_index ; field Str focus_options
  field CBool send_display_instruction
  field Link:Sem attached_sem
  field Link:Dictionary attached

export BrowserConnection '. stream'
export '. section_current'
export '. url_path' '. url_subpath' '. url_options'
export '. user_name' '. user_rights'
export '. event' '. key' '. buttons' '. x' '. y'
export '. hook_id' '. hook_x0' '. hook_y0' '. hook_x1' '. hook_y1'
export '. target_id' '. target_index' '. target_options'
export '. target_x0' '. target_y0' '. target_x1' '. target_y1'
export '. focus_id' '. focus_index' '. focus_options'
export '. send_display_instruction'
export '. attached_sem' '. attached'
export '. remote_ip_address' '. user_name' '. user_auth_level' '. user_rights'
export '. language'


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


type BrowserAttribute
  field Str name
  field Link:Type type

type BrowserTag
  field Str name
  field Dictionary attributes
  field Array:Str required
  field CBool body <- false


method c create tag
  arg_rw BrowserConnection c ; arg Str tag
  c:stream writeline "t "+string:tag

method c create_open tag parent
  arg_rw BrowserConnection c ; arg Str tag ; arg_w Str parent
  c:stream writeline "o "+string:tag

method c create_close parent
  arg_rw BrowserConnection c ; arg Str parent
  c:stream writeline "c"

method c attribute attr value
  arg_rw BrowserConnection c ; arg Str attr value
  c:stream writeline "a "+string:attr+" "+string:value

constant to_index (the_function '. to string' Universal Str -> Str):generic_index

function to_string data options function -> string
  arg Universal data ; arg Str options ; arg Function function ; arg Str string
  indirect

method c attribute attr data fun
  arg_rw BrowserConnection c ; arg Str attr ; arg Universal data ; arg Function fun
  var Str value := to_string data "db" fun
  c:stream writeline "a "+string:attr+" "+string:value

function active_type t access e
  arg BrowserTag t ; arg Int access ; arg_rw Expression e
  if e:size<1+t:required:size+(shunt t:body 1 0)
    return
  if not (e:0 cast BrowserConnection)
    return
  e suckup e:0
  if t:body
    var Link:Argument parent :> argument local Str
    e add (instruction (the_function '. create_open' BrowserConnection Str Str) e:0:result (argument constant Str t:name) parent)
  else
    e add (instruction (the_function '. create' BrowserConnection Str) e:0:result (argument constant Str t:name))
  for (var Int i) 0 t:required:size-1
    var Link:BrowserAttribute a :> (t:attributes first t:required:i) map BrowserAttribute
    if not (e:(i+1) cast a:type)
      return
    e suckup e:(i+1)
    if a:type=Str
      e add (instruction (the_function '. attribute' BrowserConnection Str Str) e:0:result (argument constant Str a:name) e:(i+1):result)
    else
      var Link:Function fun :> a:type get_generic_method to_index
      if addressof:fun=null or addressof:fun=addressof:(the_function '. to string' Universal Str -> Str)
        return
      e add (instruction (the_function '. attribute' BrowserConnection Str Universal Function) e:0:result (argument constant Str a:name) e:(i+1):result (argument mapped_constant Function fun))
  var Int i := 1+t:required:size
  while i<e:size-(shunt t:body 1 0)
    if not e:i:is_pure_ident or i+1>=e:size-(shunt t:body 1 0)
      return
    var Link:Type tt :> null map Type
    each aa t:attributes
      a :> aa map BrowserAttribute
      if a:name=e:i:ident
        tt :> a type
    if not exists:tt
      e:(i+1) compile ?
      tt :> e:(i+1):result:type real_data_type
    if not (e:(i+1) cast tt)
      return
    e suckup e:(i+1)
    if tt=Str
      e add (instruction (the_function '. attribute' BrowserConnection Str Str) e:0:result (argument constant Str e:i:ident) e:(i+1):result)
    else
      var Link:Function fun :> tt get_generic_method to_index
      if addressof:fun=null or addressof:fun=addressof:(the_function '. to string' Universal Str -> Str)
        return
      e add (instruction (the_function '. attribute' BrowserConnection Str Universal Function) e:0:result (argument constant Str e:i:ident) e:(i+1):result (argument mapped_constant Function fun))
    i += 2
  if t:body
    (e e:size-1) compile ?
    e suckup (e e:size-1)
    e add (instruction (the_function '. create_close' BrowserConnection Str) e:0:result parent)
  e set_void_result
  

function the_tag e -> t
  arg Expression e ; arg_C BrowserTag t
  var Pointer:Arrow c :> pliant_general_dictionary first "pliant current browser tag"
  if c<>null and entry_type:c=BrowserTag
    t :> c map BrowserTag
  else
    t :> null map BrowserTag

meta browser_tag_prototype e
  if e:size<2 or not e:0:is_pure_ident
    return
  var Link:BrowserTag t :> new BrowserTag
  t name := e:0 ident
  var Int i := 1
  while i<e:size-1
    if e:i:is_pure_ident
      t required += e:i:ident
      i += 1
    else
      return
  var Address mark := e:module mark
  e:module define "pliant current browser tag" addressof:t
  e:(e:size-1):compile ?
  e:module rewind mark
  e define ". "+t:name addressof:t e:module:actual
  e set_void_result

meta attr e
  var Link:BrowserTag t :> the_tag e
  if not exists:t
    return
  if e:size<>2 or (e:0 constant Type)=null or not e:1:is_pure_ident
    return
  var Link:BrowserAttribute a :> new BrowserAttribute
  a name := e:1 ident 
  a type :> (e:0 constant Type) map Type
  t:attributes insert a:name true addressof:a
  e set_void_result

meta body e
  var Link:BrowserTag t :> the_tag e
  if exists:t and e:size=0
    t body := true
    e set_void_result


export browser_tag_prototype attr body


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


public
  type BrowserVariable
    field Arrow variable
    field Str data_path
    field DelayedAction run

  type BrowserSection
    field DelayedAction refresh
    field Dictionary attached

  type BrowserPendingThread
    field DateTime timestamp
    field Link:Sem attached_sem
    field Link:Dictionary attached
    field DelayedAction action

  gvar Sem browser_thread_sem
  gvar (Dictionary Str BrowserPendingThread) browser_thread_dict


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


method c assign_rights uname
  arg_rw BrowserConnection c ; arg Str uname
  var Data:User u :> user uname
  if u:language<>""
    c language := u language
    var Int index := language_index u:language
    if index<>undefined
      current_thread_header language_index := index
  each r u:right
    if (string c:user_auth_level)>=r:auth and (c:remote_ip_address is_inside_ip_domain r:ip) and (r:server="" or (" "+r:server+" " search " "+computer_fullname+" " -1)<>(-1))
      c:user_rights kmap r:right CBool := true
      if r:right="administrator"
        c user_is_admin := true

method c assign_rights
  arg_rw BrowserConnection c
  c user_rights := var Dictionary empty_dictionary
  if not c:user_is_admin
    c assign_rights "anonymous"
    each t (user c:user_name):template
      c assign_rights t
    if c:user_name<>""
      c assign_rights c:user_name


method c allowed right -> a
  arg BrowserConnection c ; arg Str right ; arg CBool a
  a := c:user_is_admin or (c:user_rights first right)<>null and right<>""


export '. allowed'


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


gvar Dictionary pages_dictionary
gvar Sem pages_sem

named_expression browser_page_prototype
  function 'pliant browser page function' connection
    arg_rw BrowserConnection connection
    implicit connection
      body

meta browser_page e
  if e:size=2 and (e:0 constant Str)<>null and e:1:ident="{}"
    var Address mark := e:module mark
    var Link:Expression ee :> expression duplicate browser_page_prototype substitute body e:1 near e
    error_push_record (var ErrorRecord er) error_filter_all
    ee compile
    if er:id<>error_id_noerror
      console er:message eol
      er id := error_id_noerror
      e suckup_error ee
    error_pull_record er
    var Link:Function f :> (pliant_general_dictionary first "pliant browser page function") map Function
    e:module rewind mark
    if exists:f
      pages_sem request
      pages_dictionary insert ((e:0 constant Str) map Str) true addressof:f
      pages_sem release
      e set_void_result


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


type BrowserServer
  tcp_server_fields "Browser" browser_default_tcp_port
TcpServer maybe BrowserServer

function browser_type_function connection f
  arg_rw BrowserConnection connection ; arg Function f
  indirect

function execute1 a f
  arg Address a ; arg Function f
  indirect

constant from_index (the_function '. from string' Universal Str Str CBool Int Int -> Status):generic_index

function from_string data string options may_skip skiped offset function -> status
  arg Universal data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Function function ; arg Status status
  indirect

method server service s0
  arg_rw BrowserServer server ; arg_rw Stream s0
  var Link:Stream s :> s0
  var BrowserConnection c
  c stream :> s
  c remote_ip_address := s safe_query "remote_ip_address"
  if c:remote_ip_address="loopback"
    c user_is_admin := true
  c attached_sem :> new Sem
  c attached :> new Dictionary
  while not s:atend
    var Str l := s readline
    if browser_trace
      console "<- " l eol
    if (l parse word:"connect" (var Str path) (var Str options))
      c url_path := path
      c url_options := options
      if (path eparse any "://" any "/" any:(var Str subpath))
        path := "/"+subpath
      pages_sem rd_request
      var Str base := path
      var Link:Function f :> (pages_dictionary first base) map Function
      while not exists:f and base<>""
        base := base 0 ((base 0 base:len-1) search_last "/" -1)+1
        f :> (pages_dictionary first base) map Function
      pages_sem rd_release
      if exists:f
        c url_subpath := path base:len path:len
        c send_display_instruction := true
        # console "executing " path eol
        var Str id := generate_id
        s writeline "i [dq]main[dq]"
        s writeline "o [dq]section[dq]"
        browser_type_function c f
        s writeline "c"
        s writeline "window_root [dq]main[dq] [dq]main[dq]"
        if c:send_display_instruction
          s writeline "display"
      else
        console "no '" c:url_path "' page here" eol
    eif (l parse word:"run" (var Str id) any) and (id parse word:"run" (var Str sid) (var Str bid))
      c hook_id := id
      c hook_x0 := l option "hook_x0" Float
      c hook_y0 := l option "hook_y0" Float
      c hook_x1 := l option "hook_x1" Float
      c hook_y1 := l option "hook_y1" Float
      c event := l option "event" Str
      c key := l option "key" Str
      c buttons := l option "buttons" Int
      c x := l option "x" Float
      c y := l option "y" Float
      c target_id := l option "target_id" Str
      c target_index := l option "target_index" Int
      c target_options := l option "target_options" Str
      c target_x0 := l option "target_x0" Float
      c target_y0 := l option "target_y0" Float
      c target_x1 := l option "target_x1" Float
      c target_y1 := l option "target_y1" Float
      c focus_hook := l option "focus_hook" Str
      c focus_id := l option "focus_id" Str
      c focus_index := l option "focus_index" Int
      c focus_options := l option "focus_options" Str
      c event := l option "event" Str
      c key := l option "key" Str
      c buttons := l option "buttons" Int
      c x := l option "x" Float
      c y := l option "y" Float
      c:attached_sem request
      var Link:BrowserSection se :> (c:attached first sid) map BrowserSection
      if exists:se and (entry_type addressof:se)=BrowserSection
        var Link:DelayedAction da :> (se:attached first bid) map DelayedAction
        if exists:da and (entry_type addressof:da)=DelayedAction
          c send_display_instruction := true
          var DelayedAction action := da
          c:attached_sem release
          execute1 action:parameter action:function
          if c:send_display_instruction
            s writeline "display"
          c:attached_sem request
      c:attached_sem release
    eif (l parse word:"key" (var Str key) any)
      c:attached_sem request
      var Link:DelayedAction da :> (c:attached first "key "+key) map DelayedAction
      if exists:da and (entry_type addressof:da)=DelayedAction
        c send_display_instruction := true
        var DelayedAction action := da
        c:attached_sem release
        execute1 action:parameter action:function
        if c:send_display_instruction
          s writeline "display"
        c:attached_sem request
      c:attached_sem release
    eif (l parse word:"set" (var Str id) (var Str value)) and (id parse word:"set" (var Str sid) (var Str vid))
      c:attached_sem request
      var Link:BrowserSection se :> (c:attached first sid) map BrowserSection
      if exists:se and (entry_type addressof:se)=BrowserSection
        var Link:BrowserVariable va :> (se:attached first vid) map BrowserVariable
        if exists:va and (entry_type addressof:va)=BrowserVariable
          if va:variable<>null
            var Pointer:Function fun :> (entry_type va:variable) get_generic_method from_index
            if exists:fun and fun<>(the_function '. from string' Universal Str Str CBool Int Int -> Status)
              from_string (va:variable map Universal) value "db" true (var Int skiped) (var Int offset) fun 
          if va:data_path<>""
            var Data_ data := data_root search_path va:data_path false
            data:base:sem request
            var Status status := data:interface set data addressof:value Str
            data:base:sem release
          if (exists va:run:function)
            var DelayedAction action := va run
            c:attached_sem release
            execute1 action:parameter action:function
            c:attached_sem request
      c:attached_sem release
    eif (l parse word:"thread" (var Str id))
      browser_thread_sem request
      var Pointer:BrowserPendingThread pending :> browser_thread_dict first id
      if exists:pending
        var DelayedAction action := pending action
        var Pointer:Type t :> entry_type action:parameter
        for (var Int i) 0 t:nb_fields-1
          if (t field i):name="connection"
            (action:parameter translate Byte (t field i):offset) map Address := addressof c
        c attached_sem :> pending attached_sem
        c attached :> pending attached
      browser_thread_dict remove pending
      browser_thread_sem release
      if exists:pending
        execute1 action:parameter action:function
    eif (l parse word:"login" (var Str user) (var Str password))
      console "login " user " "
      var Data:UserSecret u :> user_secret_database:data:user user
      if u:password_md5=string_md5_hexa_signature:password
        c user_name := user
        c user_auth_level := 1
      c assign_rights
    eif l="channel"
      var Link:Stream channel :> new Stream
      channel open "channel:/server/"+string:browser_default_tcp_port "" in+out+safe pliant_default_file_system s
      if channel=success
        s :> channel
        c stream :> channel
        var Str ruser := channel safe_query "remote_user"
        if ruser<>""
          c user_name := ruser
          c user_auth_level := 3
          c assign_rights
    eif (l parse word:"font" (var Str fname))
      var Link:Font font :> font fname
      if exists:font
        s writeline "font bbox "+(string font:bbox_x0)+" "+(string font:bbox_y0)+" "+(string font:bbox_x1)+" "+(string font:bbox_y1)+" vector "+(string font:vector:x)+" "+(string font:vector:y)+(shunt font:fixed " fixed" "")
      else
        s writeline "no '"+fname+"' font here"
    eif (l parse word:"char" (var Str fname) (var Str chars8))
      var Link:Font font :> font fname
      if exists:font
        var Str32 chars := utf8_decode chars8
        for (var Int i) 0 chars:len-1
          var Pointer:FontChar char :> font:chars first chars:i:number
          if exists:char
            s writeline "char "+(string chars:i:number)+" bbox "+(string char:bbox_x0)+" "+(string char:bbox_y0)+" "+(string char:bbox_x1)+" "+(string char:bbox_y1)+" vector "+(string char:vector:x)+" "+(string char:vector:y)
            for (var Int j) 0 char:curves:size-1
              var Pointer:Curve curve :> char:curves j
              s writeline "c "+(string curve:mode)
              for (var Int k) 0 curve:size-1
                var Pointer:CurvePoint point :> curve point k
                if point:out_x=0 and point:out_y=0 and point:in_x=0 and point:in_y=0
                  s writeline "a "+(string point:x)+" "+(string point:y)
                else
                  s writeline "p "+(string point:x)+" "+(string point:y)+" "+(string point:in_x)+" "+(string point:in_y)+" "+(string point:out_x)+" "+(string point:out_y)
          else
            s writeline "char "+(string chars:i:number)
      s writeline "done"
    else
      console "invalid '" l "' instruction" eol


define_tcp_server BrowserServer browser_server
export browser_server browser_page
export BrowserServer '. detached' '. channel'