Patch title: Release 96 bulk changes
Abstract:
File: /pliant/graphic/ui/server/instructions.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/util/pml/io.pli"
module "/pliant/util/pml/body.pli"
module "/pliant/language/stream/blob.pli"
module "context.pli"
module "/pliant/protocol/http/site.pli"
module "/pliant/storage/database.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/math/vector.pli"
module "/pliant/math/curve.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/language/type/misc/blob.pli"

module "/pliant/fullpliant/user.pli"
module "/pliant/admin/md5.pli"
module "/pliant/protocol/common/misc.pli"
module "/pliant/language/type/text/language.pli"
module "/pliant/language/schedule/threads_engine.pli"

constant debug true


method c allowed name -> a # FIXME: code is duplicated from api.pli
  arg_rw UIServerContext c ; arg Str name ; arg CBool a
  a := c:user_is_admin or (c:user_rights first name)<>null and name<>""


ui_server_instruction pliant
  if not (connection itag "pliant")
    connection error "invalid 'pliant' instruction"


ui_server_instruction login
  if (connection itag "login" (var Str user) (var Str password))
    user_name := ""
    user_is_admin := false
    user_auth_level := 0
    user_rights := var Dictionary empty_rights_dict
    var Data:UserSecret us :> user_secret_database:data:user user
    if us:password_md5=string_md5_hexa_signature:password
      user_name := user
      user_auth_level := 1
      var Data:User u :> user user
      if u:language<>""
        var Int index := language_index u:language
        if index<>undefined
          current_thread_header language_index := index
      # var Str ip := connection safe_query "remote_ip_address"
      each r u:right
        # FIXME: apply IP contrain
        # if string:user_auth_level>=r:auth and (ip is_inside_ip_domain r:ip) and (r:server="" or (" "+r:server+" " search " "+computer_fullname+" " -1)<>(-1))
        if string:user_auth_level>=r:auth and (r:server="" or (" "+r:server+" " search " "+computer_fullname+" " -1)<>(-1))
          user_rights kmap r:right CBool := true
          if r:right="administrator"
            user_is_admin := true
    else
      console "login failed " user eol
  else
    connection error "invalid 'login' instruction"


function page_prototype context fun
  arg_rw UIServerContext context ; arg Function fun
  indirect

ui_server_instruction connect
  if (connection itag "connect" (var Str site_name) (var Str url))
    # console "connect instruction '" site_name "' '" url "'" eol
    var Data:Site site :> site_database:data:site site_name
    if site:computer<>computer_fullname and site:computer<>""
      site :> var Data:Site no_site
    var Int longuest := 0
    var Data:SiteArea area
    each a site:area
      var Str p := a path
      if (url 0 p:len)=p
        var Int l := p len
        if l>longuest
          area :> a
          longuest := l
        eif l=longuest
          area :> var Data:SiteArea nonexisting_area
    if (allowed area:read)
      user_rights kmap "read" Bool := true
    else
      if debug
        console "not allowed" eol
      connection otag "rejected"
      connection flush anytime
      connection error "not allowed"
      return
    if (allowed area:write)
      user_rights kmap "write" Bool := true
    if area:root<>""
      url := area:root+(url area:path:len url:len)
    ui_tree_sem rd_request
    var Int i := url len
    # FIXME: two slow
    while { var Link:Function fun :> (ui_tree_functions first (url 0 i)) map Function ; not exists:fun and i>0 }
      i -= 1
    ui_tree_sem rd_release
    if exists:fun
      context url := url
      context subpath := url i url:len
      context env := var Dictionary empty_dictionary
      connection oraw open (cast "group" Ident) body
      page_prototype context fun
      connection oraw close
    else
      connection otag "unknown"
      connection flush anytime
      connection error "unkown url '"+url+"' requested"
  else
    connection error "invalid 'connect' instruction"


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

ui_server_instruction set
  env_sem request
  if (connection itag "set" (var Str id) (var Str value))
    if not default_charset_is_utf8
      value := utf8_decode value
    if (id parse (var Str sid) (var Str vid))
      var Link:UIServerSection section :> (env first "section "+sid) map UIServerSection
      if exists:section and (entry_type addressof:section)=UIServerSection
        var Link:UIServerVariable va :> (section:env first vid) map UIServerVariable
        if exists:va and (entry_type addressof:va)=UIServerVariable
          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
  env_sem release


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

ui_server_instruction run
  env_sem request
  if (connection itag "run" (var Str id))
    if (id parse (var Str sid) (var Str bid))
      var Link:UIServerSection section :> (env first "section "+sid) map UIServerSection
      if exists:section and (entry_type addressof:section)=UIServerSection
        var Link:DelayedAction da :> (section:env first bid) map DelayedAction
        if exists:da and (entry_type addressof:da)=DelayedAction
          env_sem release
          connection oraw open (cast "group" Ident) body
          execute1 da:parameter da:function
          connection oraw close
          env_sem request
  env_sem release


ui_server_instruction event
  env_sem request
  if (connection itag "event" (var Str id))
    if (id parse (var Str sid) (var Str bid))
      var Link:UIServerSection section :> (env first "section "+sid) map UIServerSection
      if exists:section and (entry_type addressof:section)=UIServerSection
        connection iattr "event" event
        connection iattr "key" key
        connection iattr "buttons" buttons
        connection iattr "x" pointer_x
        connection iattr "y" pointer_y
        connection iattr "pointer_section" pointer_section
        connection iattr "pointer_index" pointer_index
        connection iattr "sx" hook_size_x
        connection iattr "sy" hook_size_y
        connection iattr "focus_section" focus_section
        connection iattr "focus_index" focus_index
        connection iattr "event_options" event_options
        for (var Int i ) 0 5
          var Str cat := shunt i=0 "clic" i=1 "event" i=2 "change" i=3 "focus" i=4 "over" i=5 "move" "?"
          var CBool concerned
          if i=0
            concerned := event="press" and key="button1"
          eif i=1
            concerned := event="press" or event="release" or event="character" or event="uncharacter"
          else
            concerned := event=cat
          if concerned
            var Link:DelayedAction da :> (section:env first bid+" "+cat) map DelayedAction
            if exists:da and (entry_type addressof:da)=DelayedAction
              env_sem release
              connection oraw open (cast "group" Ident) body
              execute1 da:parameter da:function
              connection oraw close
              env_sem request
        event := "" ; key := "" ; buttons := undefined
        pointer_x := undefined ; pointer_y := undefined
        pointer_section := "" ; pointer_index := undefined
        hook_size_x := undefined ; hook_size_y := undefined
        focus_section := "" ; focus_index := undefined
        event_options := ""
  env_sem release


ui_server_instruction thread_run
  if (connection itag "thread_run" (var Str id))
    ui_thread_sem request
    var Pointer:UIPendingThread pending :> ui_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="context"
          (action:parameter translate Byte (t field i):offset) map Address := addressof context
      env_sem :> pending env_sem
      env :> pending env
    ui_thread_dict remove pending
    ui_thread_sem release
    if exists:pending
      execute1 action:parameter action:function


ui_server_instruction font
  if (connection itag "font" (var Str name))
    if (name 0 1)="/"
      var Link:Font f :> font (name 1 name:len)
      if exists:f
        connection oraw open (cast "font" Ident)
        if (connection iattr "bbox")
          connection oraw (cast "bbox" Ident) f:bbox_x0 f:bbox_y0 f:bbox_x1 f:bbox_y1
        if (connection iattr "vector")
          connection oraw (cast "vector" Ident) f:vector:x f:vector:y
        connection oraw body
        if not (connection ibody_begin)
          return
        while (connection iraw (var Int n))
          var Pointer:FontChar ch :> f:chars first n
          if exists:ch
            connection oraw open (cast "char" Ident) n
            connection oraw (cast "bbox" Ident) ch:bbox_x0 ch:bbox_y0 ch:bbox_x1 ch:bbox_y1
            connection oraw (cast "vector" Ident) ch:vector:x ch:vector:y
            connection oraw body
            for (var Int i) 0 ch:curves:size-1
              var Pointer:Curve c :> ch:curves i
              connection oraw open (cast "c" Ident) c:mode body
              for (var Int j) 0 c:size-1
                var Pointer:CurvePoint p :> c point j
                connection oraw open (cast "p" Ident) p:x p:y
                if p:in_x<>0 or p:in_y<>0
                  connection oraw (cast "i" Ident) (cast p:in_mode Int) p:in_x p:in_y
                if p:out_x<>0 or p:out_y<>0
                  connection oraw (cast "o" Ident) (cast p:out_mode Int) p:out_x p:out_y
                connection oraw close
              connection oraw close
            connection oraw close
        if not (connection ibody_end)
          return
        connection oraw close
        return
  connection oraw (var Void v)


ui_server_instruction clipboard_request
  if (connection itag "clipboard_request")
    connection oraw open (cast "clipboard_write" Ident) body
    connection raw_write clipboard_content:content clipboard_content:size
    connection oraw close


ui_server_instruction clipboard_content
  if (connection iraw open (var Ident id) body)
    clipboard :> connection
    if (exists clipboard_handler:function)
      execute1 clipboard_handler:parameter clipboard_handler:function
    clipboard :> null map Stream
    while (connection ipick open)
      connection iskip
    connection iraw close

ui_server_instruction clipboard_self
  if (connection iraw open (var Ident id) close)
    clipboard :> new Stream
    clipboard open clipboard_content in
    if (exists clipboard_handler:function)
      execute1 clipboard_handler:parameter clipboard_handler:function
    clipboard :> null map Stream


ui_server_instruction ack
  if (connection itag "ack")
    connection otag "ack"


ui_server_instruction console
  if (connection itag "console" (var Int adr))
    if (connection safe_query "remote_ip_address")="loopback"
      client_console := cast adr Address