Patch title: Release 84 bulk changes
Abstract:
File: /pliant/appli/cluster/server.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/fullpliant/this_computer.pli"
module "/pliant/language/stream.pli"
submodule "/pliant/protocol/common/tcp_server.pli"
module "/pliant/util/remote/common.pli"
module "/pliant/util/crypto/channel.pli"
module "database.pli"
module "common.pli"
module "/pliant/admin/md5.pli"

constant md5_extension false


function tcp_port -> port
  arg Int port
  if (this_computer:env:"pliant":"cluster":"port" parse port)
    void
  eif (this_computer:env:"pliant":"remote":"port" parse port)
    port += 1
  else
    port := remote_tcp_port+1

public
  type ClusterServer
    tcp_server_fields "Clustering" constant:tcp_port
TcpServer maybe ClusterServer
  
function build server
  arg_w ClusterServer server
  server:channel size := 1
  server:channel 0 := "channel:/server/"+string:tcp_port


method area data_allowed path -> allowed
  arg Data:ClusterArea area ; arg Str path ; arg CBool allowed
  each p area:data_path
    if(path 0 p:src:len)=p:src and p:src:len>0
      return true
  allowed := false

method area file_allowed path -> allowed
  arg Data:ClusterArea area ; arg Str path ; arg CBool allowed
  each p area:file_path
    if (path 0 p:src:len)=p:src and p:src:len>0
      return true
  allowed := false

method cluster service s
  arg_rw ClusterServer cluster ; arg_rw Stream s
  var Data:ClusterArea area
  var Int data_sign_limit := 2^16
  var Int file_sign_limit := 2^12
  var Link:Function file_filter :> cluster_filter area "src_file" (var Str err)
  var Link:Function data_filter :> cluster_filter area "src_data" (var Str err)
  var Str target := s safe_query "remote_site"
  while not s:atend
    var Str l := s readline
    if (l parse word:"dsign" (var Str path))
      if (area data_allowed path)
        var Data_ d := data_root search_path path false
        var Str sign := data_sign d data_filter data_sign_limit (var Int count)
        s writeline (shunt sign<>"" string:sign "overflow")
      else
        s writeline "rejected"
    eif (l parse word:"dread" (var Str path))
      if (area data_allowed path)
        var Data_ d := data_root search_path path false
        d:base:sem rd_request
        var CBool included := (data_filter_prototype d "" computer_fullname target 1 data_filter)>0
        if included
          var CBool has_value := (d:interface get d addressof:(var Str value) Str)=success
          var List:Str keys := var List:Str empty_list
          var Data_ cur := d:interface first d "" "" (var DataScanBuffer buf)
          while cur:adr<>null
            if (data_filter_prototype cur "" computer_fullname target 1 data_filter)>0
              keys += cur key
            cur := d:interface next d "" "" buf
        d:base:sem rd_release
        if included
          if has_value
            s writeline string:value
          else
            s writeline ""         
          var Pointer:Str key :> keys first
          while exists:key
            s writeline string:key
            key :> keys next key
          s writeline "end"
        else
          s writeline "excluded[lf]"
      else
        s writeline "rejected[lf]"
    eif (l parse word:"fsign" (var Str path))
      if (area file_allowed path)
        var Str sign := file_sign path file_filter file_sign_limit (var Int count) (var Intn size)
        s writeline (shunt sign<>"" string:sign "overflow")
      else
        s writeline "rejected"
    eif md5_extension and (l parse word:"fmd5" (var Str path))
      if (area file_allowed path)
        if (file_filter_prototype path 1 file_filter)>0
          s writeline file_md5_hexa_signature:path
        else
          s writeline "excluded"
      else
        s writeline "rejected"
    eif (l parse word:"flist" (var Str path))
      if (area file_allowed path)
        if (file_filter_prototype path computer_fullname target 1 file_filter)>0
          var Array:FileInfo files := file_list path extended+directories+deadlinks+relative+sorted
          for (var Int i) 0 files:size-1
            if (file_filter_prototype path+files:i:name computer_fullname target 1 file_filter)>0
              s writeline (string files:i:name)+" "+(string files:i:size)+" "+(string files:i:datetime)+" "+files:i:options
          s writeline "end"
        else
          s writeline "excluded"
      else
        s writeline "rejected"
    eif (l parse word:"fread" (var Str path) (var Intn start) (var Intn length) any:(var Str options)) or { start := 0 ; length := undefined ; l parse word:"fread" (var Str path) any:(var Str options) }
      if (area file_allowed path)
        if (file_filter_prototype path computer_fullname target 1 file_filter)>0
          if length=undefined
            length := (file_query path standard) size
          (var Stream file) open path in+safe
          if start<>0
            file configure "seek "+string:start
          if file=success
            s writeline string:length
            var Pointer:Stream s2 :> s
            if (options option "clear")
              s flush anytime
              s2 :> s channel_support
            var Intn remain := length
            part copy "send "+path
              while remain>0
                var Int step
                if remain>=2^24
                  step := 2^24
                else
                  step := remain
                step := raw_copy file s2 step step
                remain -= step
                if step=0
                  leave copy
            if remain=0
              s writeline "ok"
            else
              var Address zero := memory_zallocate 4096 null
              while remain>0
                var Int step
                if remain>=2^24
                  step := 2^24
                else
                  step := remain
                s2 raw_write zero step
                remain -= step
              memory_free zero
              s writeline "failure"
          else
            s writeline "failure"
        else
          s writeline "excluded"
      else
        s writeline "rejected"
    eif (l parse word:"area" (var Str id))
      area :> cluster_database:data:area id
      if not (exists area:src_computer:computer_fullname)
        area :> var Data:ClusterArea no_area
      if not (exists area:dest_computer:target)
        area :> var Data:ClusterArea no_area
      data_sign_limit := area data_sign_limit
      file_sign_limit := area file_sign_limit
      var CBool err0 := false
      each m area:module
        pliant_compiler_semaphore request
        if not exists:(pliant_load_module m the_module:"/pliant/language/basic/safe.pli" 0 (null map Module))
          err0 := true
        pliant_compiler_semaphore release
      file_filter :> cluster_filter area "src_file" (var Str err1)
      data_filter :> cluster_filter area "src_data" (var Str err2)
      s writeline (shunt not exists:area "rejected" err0 or err1<>"" or err2<>"" "error" "ok")
      if err1<>"" or err2<>""
        area :> var Data:ClusterArea no_area
      if area:timeout=defined
        s configure "timeout "+(string area:timeout)
    else
      s writeline "syntax"
        

define_tcp_server ClusterServer cluster_server
export cluster_server