Patch title: Release 96 bulk changes
Abstract:
File: /pliant/util/pml/channel.pli
Key:
    Removed line
    Added line
abstract
  [This is complete secured channel implementation, but it's not because:] ; eol
  list
    item [it has not been seriously review yet.]
    item [the memory buffer might not be properly cleared before beeing freed.]

doc
  [It uses RSA public/private key pairs for exchanging a secret shared key.] ; eol
  [All informations on the secured chanel are MD5 signed, then RC4 ciphered. ]

constant server_seed_bits 128
constant server_rc4_laps 10
constant client_seed_bits 128
constant client_rc4_laps 10
constant trace true

module "/pliant/language/compiler.pli"
module "/pliant/util/crypto/random.pli"
module "/pliant/util/crypto/rsa.pli"
module "/pliant/util/crypto/rc4.pli"
module "/pliant/util/crypto/cipher.pli"
module "/pliant/admin/md5.pli"
module "resolve.pli"
module "io.pli"
module "/pliant/language/type/misc/blob.pli"

module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/openmode.pli"
module "/pliant/language/stream/flushmode.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/multi.pli"

module "/pliant/fullpliant/this_computer.pli"
constant root_proxy_client this_computer:env:"pliant":"multiplexer":"root_proxy_client"="true"
if root_proxy_client
  module "/pliant/language/context.pli"
  module "/pliant/storage/database.pli"
  module "/pliant/protocol/dns/name.pli"
  module "/pliant/fullpliant/user.pli"
  module "/pliant/language/type/text/str8.pli"
  module "/pliant/language/stream/count.pli"

(gvar TraceSlot server_trace) configure "secured channel2 server"
(gvar TraceSlot client_trace) configure "secured channel2 client"


function random_seed size -> b
  arg Int size ; arg Blob b
  var Int size2 := max size DateTime:size+128\8
  b size := size2
  var DateTime dt := datetime
  memory_copy addressof:dt b:content DateTime:size
  memory_strong_random (b:content translate DateTime) size2-DateTime:size

function '+' b1 b2 -> b
  arg Blob b1 b2 b
  b size := b1:size+b2:size
  memory_copy b1:content b:content b1:size
  memory_copy b2:content (b:content translate Byte b1:size) b2:size

function string_md5_binary_signature blob -> sign
  arg Blob blob sign
  addressof:sign map Str := string_md5_binary_signature (addressof:blob map Str)


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


type SecuredStreamDriver2
  field Link:Stream s
  field RC4Ctx read_ctx
  field Str read_buffer
  field CBool read_crashed <- false
  field RC4Ctx write_ctx
  field CBool write_crashed <- false
  field Str local_class local_name
  field Str remote_class remote_name
  field Int security_level
  field Str encoding
  field Str errmsg
StreamDriver maybe SecuredStreamDriver2


doc
  [Read RC4 ciphered bytes.]

method drv read1 buf size -> status
  arg_rw SecuredStreamDriver2 drv ; arg Address buf ; arg Int size ; arg Status status
  var Int red := 0
  while red<size
    drv:s read_available (var Address adr) (var Int step) size-red
    if step=0
      return failure
    rc4_cipher drv:read_ctx adr (buf translate Byte red) step
    red += step
  status := success

doc
  [Read MD5 signed packets.] ; eol
  ['read_buffer' contains the bytes from the last packet that have not yet been consumed.]

method drv read buf mini maxi -> red
  arg_rw SecuredStreamDriver2 drv ; arg Address buf ; arg Int mini maxi red
  red := 0
  if drv:read_crashed
    return
  while red<mini
    if drv:read_buffer:len>0
      var Int step := min drv:read_buffer:len maxi
      memory_copy drv:read_buffer:characters (buf translate Byte red) step
      drv:read_buffer := drv:read_buffer step drv:read_buffer:len
      red += step
    else
      if (drv read1 addressof:(var uInt16_li step16) uInt16:size)=failure
        drv errmsg := "read block size"
        drv read_crashed := true ; return
      drv:read_buffer set (memory_allocate step16 (addressof drv:read_buffer)) step16 true
      if (drv read1 drv:read_buffer:characters step16)=failure
        drv errmsg := "read block data"
        drv read_crashed := true ; return
      var Str correct := string_md5_binary_signature drv:read_buffer
      (var Str provided) set (memory_allocate correct:len addressof:provided) correct:len true
      if (drv read1 provided:characters provided:len)=failure
        drv errmsg := "read block signature"
        drv read_crashed := true ; return
      if provided<>correct
        drv errmsg := "wrong block signature"
        drv read_crashed := true ; return
       

doc
  [Writes RC4 ciphered bytes.]

method drv write1 buf size -> status
  arg_rw SecuredStreamDriver2 drv ; arg Address buf ; arg Int size ; arg Status status
  var Int written := 0
  while written<size
    var Int step := min (cast drv:s:stream_write_stop Int).-.(cast drv:s:stream_write_cur Int) size-written
    rc4_cipher drv:write_ctx (buf translate Byte written) drv:s:stream_write_cur step
    drv:s stream_write_cur := drv:s:stream_write_cur translate Byte step
    if drv:s:stream_write_cur=drv:s:stream_write_stop
      drv:s flush anytime
      if drv:s:is_crashed
        return failure
    written += step
  status := success

doc
  [Writes MD5 signed packets.]

method drv write buf mini maxi -> written
  arg_rw SecuredStreamDriver2 drv ; arg Address buf ; arg Int mini maxi written
  written := 0
  if drv:write_crashed
    return
  while written<mini
    var uInt16_li step16 := min maxi-written 2^16-1
    if (drv write1 addressof:step16 uInt16:size)=failure
      drv errmsg := "write block size"
      drv write_crashed := true ; return
    if (drv write1 (buf translate Byte written) step16)=failure
      drv errmsg := "write block data"
      drv write_crashed := true ; return
    (var Str temp) set (buf translate Byte written) step16 false
    var Str digest := string_md5_binary_signature temp
    if (drv write1 digest:characters digest:len)=failure
      drv errmsg := "write block signature"
      drv write_crashed := true ; return
    written += step16


method drv flush level -> status
  arg_rw SecuredStreamDriver2 drv ; arg Int level ; arg Status status
  if level<>end
    drv:s flush level
  status := shunt drv:s=success success failure


method drv query command stream answer -> status
  arg_rw SecuredStreamDriver2 drv ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status 
  if command="local_class"
    answer := drv local_class
    status := success
  eif command="local_name"
    answer := drv local_name
    status := success
  eif command="remote_class"
    answer := drv remote_class
    status := success
  eif command="remote_name"
    answer := drv remote_name
    status := success
  eif command="security_level"
    answer := string drv:security_level
    status := success
  eif command="encoding"
    answer := drv encoding
    status := success
  eif command="error_message"
    answer := drv errmsg
    status := success
  else
    status := drv:s:stream_driver query command drv:s answer


method drv configure command stream -> status
  arg_rw SecuredStreamDriver2 drv ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status
  status := drv:s:stream_driver configure command drv:s


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


doc
  [Exchange a new shared secret key between the client and the server.] ; eol
  list
    item [The client will generate a seed and send it to the server, ciphered with the server public key (1)]
    item [The server will reply with a seed of it's own, ciphered with the client public key (2a)]
    item [Then the server will send the client seed, ciphered with the client public key (2b)]
    item [The client will check it's own seed sent back by the server: the server identity is proved]
    item [Then the client will send the server seed, ciphered with the server public key (3)]
    item [The server will check it's own seed sent back by the client: the client identity is proved]
    item [The new shared secret is the client seed followed by the server seed.]


function server_exchange_key s server_class server_name client_class client_name log -> key
  arg_rw Stream s ; arg Str server_class server_name client_class client_name ; arg_rw TraceSession log ; arg Blob key
  key size := 0
  var Str server_public := resolve_public_key server_class server_name
  var Str server_private := resolve_private_key server_class server_name ""
  if server_public="" or server_private=""
    log trace "missing server key (server_exchange_key)."
    return
  var Str client_public := resolve_public_key client_class client_name
  if client_public=""
    log trace "missing client key (server_exchange_key)."
    return
  # wait for the client seed
  if not s:iavailable or not (s itag "exchange1")
    return
  (var Blob client_key) size := 0
  if (s iattr "key" (var Blob blob))
    client_key := rsa_cipher blob server_private
  if client_key:size=0
    log trace "wrong client seed (server_exchange_key)."
    return
  # send the server seed
  (var Blob server_key) size := (max rsa_nbbits:server_public rsa_nbbits:client_public)\8
  memory_strong_random server_key:content server_key:size
  s otag "exchange2"
  s oattr "key" (rsa_cipher server_key client_public) ; s oattr "rsa"
  # send the client seed back
  s oattr "sign" (rsa_cipher client_key client_public)
  # wait for the server seed back
  (var Blob back) size := 0
  if not s:iavailable or not (s itag "exchange3")
    return
  if (s iattr "sign" (var Blob blob))
    back := rsa_cipher blob server_private 
  if (memory_different back:content back:size server_key:content server_key:size)
    # client answer is wrong (server seed back)
    log trace "wrong client answer (server_exchange_key)."
    return
  key := client_key+server_key
  resolve_set_shared_key server_class server_name "" client_class client_name "" key


function client_exchange_key s server_class server_name client_class client_name client_password log -> key
  arg_rw Stream s ; arg Str server_class server_name client_class client_name client_password ; arg_rw TraceSession log ; arg Blob key
  key size := 0
  var Str server_public := resolve_public_key server_class server_name
  if server_public=""
    log trace "missing server key (client_exchange_key)."
    return
  var Str client_public := resolve_public_key client_class client_name
  var Str client_private := resolve_private_key client_class client_name client_password
  if client_public="" or client_private=""
    log trace "missing client key (client_exchange_key)."
    return
  # send the client seed
  (var Blob client_key) size := (max rsa_nbbits:server_public rsa_nbbits:client_public)\8
  memory_strong_random client_key:content client_key:size
  s otag "exchange1"
  s oattr "key" (rsa_cipher client_key server_public) ; s oattr "rsa"
  # wait for the server seed and the client seed back
  (var Blob server_key) size := 0
  (var Blob back) size := 0
  if not s:iavailable or not (s itag "exchange2")
    return
  if (s iattr "key" (var Blob blob))
    server_key := rsa_cipher blob client_private
  if (s iattr "sign" (var Blob blob))
    back := rsa_cipher blob client_private
  if server_key:size=0 or (memory_different back:content back:size client_key:content client_key:size)
    # server answer is wrong (client seed back)
    log trace "wrong server answer (client_exchange_key)."
    return
  # send the server seed back
  s otag "exchange3"
  s oattr "sign" (rsa_cipher server_key server_public)
  key := client_key+server_key
  memory_copy client_key:content key:content client_key:size
  memory_copy server_key:content (key:content translate Byte client_key:size) server_key:size
  resolve_set_shared_key client_class client_name "" server_class server_name "" key


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

doc
  [Open a new secured channel.] ; eol
  list
    item [The client will send a seed (1)]
    item [The server will send a seed (2a)]
    item [The server will answer with a MD5 digest of the shared secret + client seed (2b)]
    item [The client will answer with a MD5 digest of server seed + shared secret (3)]
    item [Both sides check the MD5 answers, and a new shared secret is negociated if they where wrong or there was no shared secret yet.]
  [The server will cipher using RC4 and the key will be client seed + shared secret + server seed] ; eol
  [The client will cipher using RC4 and the key will be server seed + shared secret + client seed]


type SecuredFileSystem2
  void
FileSystem maybe SecuredFileSystem2

function open_server_channel port log options flags stream support -> status
  arg Int port ; arg_rw TraceSession log ; arg Str options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  log bind server_trace
  # this is the server side: this code is executed on the server when a client is asking for a secured channel
  var Link:Stream s
  if addressof:support<>null
    s :> support
  else
    var Link:Stream s :> new Stream
    s open "tcp:/server/"+string:port "" in+out+(flags .and. safe)
    if s=failure
      log trace "Failed to connect to " s:name
      return (failure "failed to listen TCP port "+string:port)
  if not (s itag "pliant")
    return failure:"Not a PML startup"
  if not (s iattr "from_class" (var Str client_class))
    client_class := ""
  if not (s iattr "to_class" (var Str server_class))
    server_class := ""
  if false
    if not (s iattr "service" (var Str service))
      service := ""
    if service="browser"
      client_class := "user" ; server_class := "host"
    eif service="execute" or service="storage"
      client_class := "host" ; server_class := "host"
  if client_class="" or server_class=""
    return failure:"no client or server class"
  if not (s iattr "from" (var Str client_name))
    client_name := ""
  if not (s iattr "to" (var Str server_name))
    server_name := ""
  if client_name="" or server_name=""
    return failure:"no client or server name"
  # receive the client seed
  (var Blob client_seed) size := 0
  var Int client_laps := undefined
  var Str encoding := ""
  var CBool query_client := false
  var CBool query_server := false
  if not s:iavailable or not (s itag "channel1")
    return failure:"expected channel1 instruction"
  if (s iattr "seed" (var Blob blob))
    client_seed := blob
  if (s iattr "rc4" (var Int i))
    client_laps := i
  if (s iattr "encoding" (var Str enc))
    if enc="deflate" or enc="zlib"
      encoding := enc
  if (s iattr "query_client_key")
    query_client := true
  if (s iattr "query_server_key")
    query_server := true
  s otag "channel2"
  if query_client
    s oattr "client_class" client_class
    s oattr "client_name" client_name
    s oattr "client_key" (resolve_public_key client_class client_name)
  if query_server
    s oattr "server_class" server_class
    s oattr "server_name" server_name
    s oattr "server_key" (resolve_public_key server_class server_name)
  if encoding<>""
    s oattr "encoding" encoding
  log trace "secured server: connection from " client_class " " client_name " to " server_class " " server_name
  if client_seed:size=0 or client_laps=undefined
    log trace "wrong client seed or laps."
    return failure:"wrong client seed or laps"
  if (resolve_private_key server_class server_name "")=""
    log trace "no private key for " server_name
    return (failure "no private key for "+server_name)
  # send server seed
  var Blob server_seed := random_seed server_seed_bits\8
  var Int server_laps := server_rc4_laps
  s oattr "seed" server_seed ; s oattr "rc4" server_laps
  # retreive the shared secret with this client (may be empty if they never talked together or the sever discarded it)
  var Blob key := resolve_get_shared_key server_class server_name "" client_class client_name ""
  # send MD5 digest of shared secret + client seed
  s oattr "sign" (string_md5_binary_signature key+client_seed) ; s oattr "md5"
  # wait for the MD5 digest of server seed + shared secret
  (var Blob back) size := 0
  if not s:iavailable or not (s itag "channel3")
    return failure:"expected channel3 instruction"
  if (s iattr "sign" (var Blob blob))
    back := blob
  var Blob sign := string_md5_binary_signature server_seed+key
  if (memory_different back:content back:size sign:content sign:size) or key:size=0
    # the MD5 was wrong or there was no shared secret: we must negotiate a new one using RSA keys
    log trace "secured server: needs to exchange a shared key."
    part exchange "exchange secret keys"
      key := server_exchange_key s server_class server_name client_class client_name log
    if key:size=0
      log trace "failed to exchange a shared key."
      return failure:"failed to exchange a shared key"
  s iflush
  log trace "secured server: session opened (" key:size ")."
  var Link:SecuredStreamDriver2 drv :> new SecuredStreamDriver2
  if (flags .and. out)<>0
    var Blob final := client_seed+key+server_seed
    rc4_init drv:write_ctx (addressof:final map Str) server_laps
  if (flags .and. in)<>0
    var Blob final := server_seed+key+client_seed
    rc4_init drv:read_ctx (addressof:final map Str) client_laps
  drv local_class := server_class
  drv local_name := server_name
  drv remote_class := client_class
  drv remote_name := client_name
  drv security_level := min rsa_nbbits:(resolve_public_key server_class server_name) rsa_nbbits:(resolve_public_key client_class client_name)
  log trace "secured server: security level is " drv:security_level " bits"
  drv s :> s
  if encoding<>""
    log trace "secured server: encoding is " encoding
    drv encoding := encoding
    var Link:Stream zs :> new Stream
    if (zs open "null2:" options flags)=failure
      return failure
    zs stream_driver :> drv
    if (pliant_default_file_system open encoding+":" options flags stream zs)=failure
      return failure
  else
    stream stream_driver :> drv
  status := success
  log trace "secured channel " server_class " " server_name " <- " client_class " " client_name


function open_client_channel service server_class server_name client_class client_name client_password log options flags stream support -> status
  arg Str service server_class server_name client_class client_name client_password ; arg_rw TraceSession log ; arg Str options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  # this is the client side: this code is executed on the client when trying to get a secured channel to a server
  log bind client_trace
  var Link:Stream s
  if addressof:support<>null
    s :> support
  else
    resolve_ip server_class server_name "" (options option "smart") (var Str ip) (var Int port) (var CBool forward) (var Int count)
    if ip="" or forward
      return (failure "failed to find IP and port for '"+server_name+"'")
    var Link:Stream s :> new Stream
    s open "tcp://"+ip+"/client/"+string:port "" in+out+(flags .and. safe)
    if s=failure
      log trace "failed to connect to " s:name
      return (failure "failed to connect to '"+ip+"' TCP port "+string:port)
    var Int index := 0
    part connect
      resolve_ip server_class server_name "" index (var CBool distant) (var Str ip) (var Int port) (var Int count)
      if ip=""
        return (failure "failed to find IP and port for '"+server_name+"'")
      var Link:Stream s :> new Stream
      s open "tcp://"+ip+"/client/"+string:port "" in+out+(flags .and. safe)
      if s=failure
        if index+1<count
          index += 1
          restart connect
        log trace "failed to connect to " s:name
        return (failure "failed to connect to '"+ip+"' TCP port "+string:port)
  s otag "pliant"
  s oattr "service" service
  s oattr "from_class" client_class
  s oattr "from" client_name
  s oattr "to_class" server_class
  s oattr "to" server_name
  s oattr "secured"
  # send a seed
  var Blob client_seed := random_seed client_seed_bits\8
  var Int client_laps := client_rc4_laps
  s otag "channel1"
  s oattr "seed" client_seed ; s oattr "rc4" client_laps
  if (options option "query_server_key")
    s oattr "query_server_key"
  if (options option "query_client_key")
    s oattr "query_client_key"
  if (options option "deflate")
    s oattr "encoding" "deflate"
  eif (options option "zlib")
    s oattr "encoding" "zlib"
  # receive MD5 digest of shared secret + client seed
  # also receive the server seed
  (var Blob back) size := 0
  (var Blob server_seed) size := 0
  var Int server_laps := undefined
  var Str encoding := ""
  if not s:iavailable or not (s itag "channel2")
    return failure:"expected channel2 instruction"
  if (s iattr "sign" (var Blob blob))
    back := blob
  if (s iattr "seed" (var Blob blob))
    server_seed := blob
  if (s iattr "rc4" (var Int i))
    server_laps := i
  if (s iattr "encoding" (var Str enc))
    if enc="deflate" or enc="zlib"
      encoding := enc
      log trace encoding+" encoding accepted."
  log trace "secured client: new connection from " client_name " to " server_name
  if server_seed:size=0 or server_laps=undefined
    log trace "wrong server seed or laps."
    return failure:"wrong server seed or laps"
  # retreive the shared secret with this client (may be empty if they never talked together or the sever discarded it)
  var Blob key := resolve_get_shared_key client_class client_name "" server_class server_name ""
  # send MD5 digest of server seed + shared secret
  s otag "channel3"
  s oattr "sign" (string_md5_binary_signature server_seed+key) ; s oattr "md5"
  var Blob sign := string_md5_binary_signature key+client_seed
  if (memory_different back:content back:size sign:content sign:size) or key:size=0
    # the MD5 was wrong or there was no shared secret: we must negotiate a new one using RSA keys
    log trace "needs to exchange a shared key."
    key := client_exchange_key s server_class server_name client_class client_name client_password log
    if key:size=0
      log trace "failed to exchange a shared key."
      return failure:"failed to exchange a shared key"
  s flush anytime
  s iflush
  log trace "session opened (" key:size ")."
  var Link:SecuredStreamDriver2 drv :> new SecuredStreamDriver2
  if (flags .and. out)<>0
    var Blob final := server_seed+key+client_seed
    rc4_init drv:write_ctx (addressof:final map Str) client_laps
  if (flags .and. in)<>0
    var Blob final := client_seed+key+server_seed
    rc4_init drv:read_ctx (addressof:final map Str) server_laps
  drv local_class := client_class
  drv local_name := client_name
  drv remote_class := server_class
  drv remote_name := server_name
  drv security_level := min rsa_nbbits:(resolve_public_key server_class server_name) rsa_nbbits:(resolve_public_key client_class client_name)
  log trace "security level is " drv:security_level " bits"
  drv s :> s
  if encoding<>""
    log trace "encoding is " encoding
    drv encoding := encoding
    var Link:Stream zs :> new Stream
    if (zs open "null2:" options flags)=failure
      return failure
    zs stream_driver :> drv
    if (pliant_default_file_system open encoding+":" options flags stream zs)=failure
      return failure
  else
    stream stream_driver :> drv
  status := success


method fs open name options flags stream support -> status
  arg_rw SecuredFileSystem2 fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  var TraceSession log
  if (name parse "/server/" (var Int port))
    status := open_server_channel port log options flags stream support
  eif (name parse "/" any:(var Str service) "/" any:(var Str server_class) "/" any:(var Str server_name) "/" any:(var Str client_class) "/" any:(var Str client_name) "/" any:(var Str client_password))
    status := open_client_channel service server_class server_name client_class client_name client_password log options flags stream support
    if root_proxy_client and client_class="user" and user_secret_database:data:user:client_name:private_key:len=0
      var Int port := (name_database:data:host name_database:data:host:computer_fullname:physical) port
      var Link:Stream tcp :> new Stream
      status := tcp open "tcp://127.0.0.1/client/"+string:port in+out+safe
      if status=success
        tcp otag "iam"
        tcp oattr "service" service
        tcp oattr "from_class" client_class
        tcp oattr "from" client_name
        tcp oattr "to_class" server_class
        tcp oattr "to" server_name
        tcp oattr "password" client_password
        if (options option "deflate")
          tcp oattr "encoding" "deflate"
        eif (options option "zlib")
          tcp oattr "encoding" "zlib"
        pliant_default_file_system open "count:" options flags stream tcp
    else
      status := open_client_channel service server_class server_name client_class client_name client_password log options flags stream support
  else
    status := failure


gvar SecuredFileSystem2 secured_file_system2
pliant_multi_file_system mount "channel2:" "" "" secured_file_system2
pliant_multi_file_system mount "zchannel2:" "" "zlib" secured_file_system2


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


type NullStreamDriver2
  void
StreamDriver maybe NullStreamDriver2

method drv read buf mini maxi -> red
  arg_rw NullStreamDriver2 drv ; arg Address buf ; arg Int mini maxi red
  memory_clear buf maxi
  red := maxi

method drv write buf mini maxi -> written
  arg_rw NullStreamDriver2 drv ; arg Address buf ; arg Int mini maxi written
  written := maxi


type NullFileSystem2
  void
FileSystem maybe NullFileSystem2

method fs open name options flags stream support -> status
  arg_rw NullFileSystem2 fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  stream stream_driver :> new NullStreamDriver2
  status := success

gvar NullFileSystem2 null_file_system2
pliant_multi_file_system mount "null2:" "" null_file_system2


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


method ch channel_support2 -> s
  arg_rw Stream ch ; arg_C Stream s
  s :> ch
  while { var Pointer:Type t :> entry_type (addressof s:stream_driver) ; t=SecuredStreamDriver2 or t:name="CompressZlibStreamDriver" }
    s :> (addressof s:stream_driver) map Link:Stream

export '. channel_support2'