Patch title: Release 93 bulk changes
Abstract:
File: /util/crypto/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 legal maximum key size is too low.]

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 backward_compatibility true

module "/pliant/language/compiler.pli"
module "random.pli"
module "rsa.pli"
module "rc4.pli"
module "cipher.pli"
module "/pliant/admin/md5.pli"
module "/pliant/util/encoding/base64.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/protocol/dns/name.pli"
module "/pliant/protocol/http/site.pli"
module "/pliant/fullpliant/user.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"

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


function random_seed len -> s
  arg Int len ; arg Str s
  var DateTime dt := datetime
  var Str timestamp := repeat DateTime:size " "
  memory_copy addressof:dt timestamp:characters DateTime:size
  part generate
    s := timestamp+random_string:(max len-DateTime:size 1)
    if (s s:len-1):number=0
      restart generate


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


type SecuredStreamDriver
  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_site
  field Str local_user
  field Str remote_site
  field Str remote_user
  field Int security_level
  field Str errmsg
  field Str wrong_block
  field Str encoding
StreamDriver maybe SecuredStreamDriver


doc
  [Read RC4 ciphered bytes.]

method drv read1 buf size -> status
  arg_rw SecuredStreamDriver 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 SecuredStreamDriver 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 wrong_block := drv read_buffer
        drv errmsg := "wrong block signature"
        drv read_crashed := true ; return
       

doc
  [Writes RC4 ciphered bytes.]

method drv write1 buf size -> status
  arg_rw SecuredStreamDriver 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 SecuredStreamDriver 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 SecuredStreamDriver 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 SecuredStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status 
  if command="local_site"
    answer := drv local_site
    status := success
  eif command="local_user"
    answer := drv local_user
    status := success
  eif command="remote_site"
    answer := drv remote_site
    status := success
  eif command="remote_user"
    answer := drv remote_user
    status := success
  eif command="security_level"
    answer := string drv:security_level
    status := success
  eif command="error_message"
    answer := drv errmsg
    status := success
  eif command="wrong_block"
    answer := drv wrong_block
    status := success
  eif command="encoding"
    answer := drv encoding
    status := success
  else
    status := drv:s:stream_driver query command drv:s answer


method drv configure command stream -> status
  arg_rw SecuredStreamDriver 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_site client_site client_user log -> key
  arg_rw Stream s ; arg Str server_site client_site client_user ; arg_rw TraceSession log ; arg Str key
  var Str server_public := name_database:data:host:server_site public_key
  var Str server_private := name_secret_database:data:host:server_site private_key
  var CBool is_host := true
  if server_public=""
    server_public := site:server_site public_key
    server_private := site_secret_database:data:site:server_site private_key
    is_host := false
  if server_public="" or server_private=""
    log trace "missing server key (server_exchange_key)."
    return ""
  var Str client_public
  if client_site<>""
    client_public := name_database:data:host:client_site public_key
    if client_public=""
      client_public := site:client_site public_key
  eif client_user<>""
    client_public := user:client_user public_key
  if client_public=""
    log trace "missing client key (server_exchange_key)."
    return ""
  # wait for the client seed
  var Str client_key := ""
  while not s:atend and { var Str l := s:readline ; l<>"" }
    if (l parse "key:" any:(var Str encoded))
      client_key := rsa_cipher base64_decode:encoded server_private
  if client_key=""
    log trace "wrong client seed (server_exchange_key)."
    return ""
  # send the server seed
  var Str server_key := random_string (max rsa_nbbits:server_public rsa_nbbits:client_public)\8
  s writeline "key: "+base64_encode:(rsa_cipher server_key client_public)
  # send the client seed back
  s writeline "sign-rsa: "+base64_encode:(rsa_cipher client_key client_public)
  s writeline "" ; s flush anytime
  # wait for the server seed back
  var Str back := ""
  while not s:atend and { var Str l := s:readline ; l<>"" }
    if (l parse "sign-rsa:" any:(var Str encoded))
      back := rsa_cipher base64_decode:encoded server_private
  if back<>server_key
    # client answer is wrong (server seed back)
    log trace "wrong client answer (server_exchange_key)."
    return ""
  key := client_key+server_key
  # stores the new shared key in the users database
  var Str client_id := shunt client_site<>"" client_site client_user
  if is_host
    name_secret_database:data:host:server_site:session create client_id
    name_secret_database:data:host:server_site:session:client_id:key := key
    name_secret_database:data:host:server_site:session:client_id:timestamp := datetime
    name_secret_database store
  else
    site_secret_database:data:site:server_site:session create client_id
    site_secret_database:data:site:server_site:session:client_id:key := key
    site_secret_database:data:site:server_site:session:client_id:timestamp := datetime
    site_secret_database store


function client_exchange_key s server_site client_site client_user password log -> key
  arg_rw Stream s ; arg Str server_site client_site client_user password ; arg_rw TraceSession log ; arg Str key
  var Str server_public := name_database:data:host:server_site public_key
  var CBool is_host := true
  if server_public=""
    server_public := site:server_site public_key
    is_host := false
  if server_public=""
    log trace "missing server key (client_exchange_key)."
    return ""
  var Str client_public client_private
  if client_site<>""
    client_public := name_database:data:host:client_site public_key
    client_private := name_secret_database:data:host:client_site private_key
    if client_public=""
      client_public := site:client_site public_key
      client_private := site_secret_database:data:site:client_site private_key
  eif client_user<>""
    client_public := user:client_user public_key
    client_private := uncipher (user_secret_database:data:user:client_user private_key) password
  if client_public="" or client_private=""
    log trace "missing client key (client_exchange_key)."
    return ""
  var Str client_key := random_string (max rsa_nbbits:server_public rsa_nbbits:client_public)\8
  s writeline "key: "+base64_encode:(rsa_cipher client_key server_public)
  s writeline "" ; s flush anytime
  # send the client seed
  # wait for the server seed and the client seed back
  var Str server_key := ""
  var Str back := ""
  while not s:atend and { var Str l := s:readline ; l<>"" }
    if (l parse "sign-rsa:" any:(var Str encoded))
      back := rsa_cipher base64_decode:encoded client_private
    if (l parse "key:" any:(var Str encoded))
      server_key := rsa_cipher base64_decode:encoded client_private
  if server_key="" or back<>client_key
    # server answer is wrong (client seed back)
    log trace "wrong server answer (client_exchange_key)."
    return ""
  # send the server seed back
  s writeline "sign-rsa: "+base64_encode:(rsa_cipher server_key server_public)
  s writeline "" ; s flush anytime
  key := client_key+server_key
  # stores the new shared key in the users database
  if client_site<>"" and is_host
    name_secret_database:data:host:client_site:session create server_site
    name_secret_database:data:host:client_site:session:server_site:key := key
    name_secret_database:data:host:client_site:session:server_site:timestamp := datetime
    name_secret_database store
  eif client_site<>"" and not is_host
    site_secret_database:data:site:client_site:session create server_site
    site_secret_database:data:site:client_site:session:server_site:key := key
    site_secret_database:data:site:client_site:session:server_site:timestamp := datetime
    site_secret_database store
  else
    user_secret_database:data:user:client_user:session create server_site
    user_secret_database:data:user:client_user:session:server_site:key := cipher key password
    user_secret_database:data:user:client_user:session:server_site:timestamp := datetime
    user_secret_database store


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

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 SecuredFileSystem
  void
FileSystem maybe SecuredFileSystem

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 Status 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)
  # receive the client seed
  var Str server_site := ""
  var Str client_site := ""
  var Str client_user := ""
  var Str client_seed := ""
  var Int client_laps := undefined
  var CBool query_client := false
  var CBool query_server := false
  var Str encoding := ""
  while not s:atend and { var Str l := s:readline ; l<>"" }
    if (l parse "server-site:" any:(var Str encoded))
      server_site := base64_decode encoded
    eif backward_compatibility and (l parse "server-user:" any:(var Str encoded))
      server_site := base64_decode encoded
    eif (l parse "client-site:" any:(var Str encoded))
      client_site := base64_decode encoded
    eif (l parse "client-user:" any:(var Str encoded))
      client_user := base64_decode encoded
    eif (l parse "seed-rc4:" any:(var Str encoded))
      client_seed := base64_decode encoded
    eif (l parse "laps-rc4:" (var Int i))
      client_laps := i
    eif (l parse "query-client-key")
      query_client := true
    eif (l parse "query-server-key")
      query_server := true
    eif (l parse "encoding:" any:(var Str enc)) and (enc="deflate" or enc="zlib")
      encoding := enc
  if query_client
    if client_site<>""
      var Str client_public := name_database:data:host:client_site public_key
      if client_public=""
        client_public := site:client_site public_key
      s writeline "client-key: "+client_public
    else
      var Str client_public := user:client_user public_key
      s writeline "client-key: "+client_public
  if query_server
    var Str server_public := name_database:data:host:server_site public_key
    if server_public<>""
      if not (server_public parse word:"rsa" _ any:(var Str part1a) _ any ) or not (name_secret_database:data:host:server_site:private_key parse word:"rsa" _ any:(var Str part1b) _ any) or part1a<>part1b
        server_public := "corrupted key"
    else
      server_public := site:server_site public_key
      if server_public<>""
        if not (server_public parse word:"rsa" _ any:(var Str part1a) _ any ) or not (site_secret_database:data:site:server_site:private_key parse word:"rsa" _ any:(var Str part1b) _ any) or part1a<>part1b
          server_public := "corrupted key"
    s writeline "server-key: "+server_public
  if encoding<>""
    s writeline "encoding: "+encoding
  log trace "secured server: connection from " (shunt client_site<>"" "site "+client_site "user "+client_user) " to site " server_site
  if client_seed="" or client_laps=undefined
    log trace "wrong client seed or laps."
    return failure
  if name_secret_database:data:host:server_site:private_key="" and site_secret_database:data:site:server_site:private_key=""
    log trace "no private key for " server_site
    return failure
  # send server seed
  var Str server_seed := random_seed server_seed_bits\8
  var Int server_laps := server_rc4_laps
  s writeline "seed-rc4: "+base64_encode:server_seed
  s writeline "laps-rc4: "+string:server_laps
  # retreive the shared secret with this client (may be empty if they never talked together or the sever discarded it)
  var Str key := name_secret_database:data:host:server_site:session:(shunt client_site<>"" client_site client_user):key
  if key=""
    key := site_secret_database:data:site:server_site:session:(shunt client_site<>"" client_site client_user):key
  # send MD5 digest of shared secret + client seed
  s writeline "sign-md5: "+base64_encode:(string_md5_binary_signature key+client_seed)
  s writeline ""
  # wait for the MD5 digest of server seed + shared secret
  var Str back := ""
  while not s:atend and { var Str l := s:readline ; l<>"" }
    if (l parse "sign-md5:" any:(var Str encoded))
      back := base64_decode encoded
  if back<>(string_md5_binary_signature server_seed+key) or key=""
    # 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_site client_site client_user log
    if key=""
      log trace "failed to exchange a shared key."
      return failure
  log trace "secured server: session opened (" key:len ")."
  var Link:SecuredStreamDriver drv :> new SecuredStreamDriver
  if (flags .and. out)<>0
    rc4_init drv:write_ctx client_seed+key+server_seed server_laps
  if (flags .and. in)<>0
    rc4_init drv:read_ctx server_seed+key+client_seed client_laps
  drv local_site := server_site
  if client_site<>""
    drv remote_site := client_site
  eif client_user<>""
    drv remote_user := client_user
  drv security_level := min (rsa_nbbits site:server_site:public_key) (shunt client_site<>"" (rsa_nbbits site:client_site:public_key) (rsa_nbbits user:client_user:public_key))
  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 "null:" 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_site " <- " (shunt client_site<>"" "site "+client_site "user "+client_user)

function open_client_channel server_site client_site client_user password port log options flags stream support -> status
  arg Str server_site client_site client_user password ; arg Int port ; arg_rw TraceSession log ; arg Str options ; arg Int flags ; arg_rw Stream stream support ; arg Status 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
    var Link:Stream s :> new Stream
    s open "tcp://"+server_site+"/client/"+string:port "" in+out+(flags .and. safe+noautopost)
    s open "tcp://"+server_site+"/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 '"+server_site+"' TCP port "+string:port)
  # send a seed
  var Str client_seed := random_seed client_seed_bits
  var Int client_laps := client_rc4_laps
  s writeline "server-site: "+base64_encode:server_site
  if backward_compatibility
    s writeline "server-user: "+base64_encode:server_site
  if client_site<>""
    s writeline "client-site: "+base64_encode:client_site
  eif client_user<>""
    s writeline "client-user: "+base64_encode:client_user
  s writeline "seed-rc4: "+base64_encode:client_seed
  s writeline "laps-rc4: "+string:client_laps
  if (options option "query_server_key")
    s writeline "query-server-key"
  if (options option "query_client_key")
    s writeline "query-client-key"
  if (options option "deflate")
    s writeline "encoding: deflate"
  eif (options option "zlib")
    s writeline "encoding: zlib"
  s writeline "" ; s flush anytime
  s writeline ""
  # receive MD5 digest of shared secret + client seed
  # also receive the server seed
  var Str back := ""
  var Str server_seed := ""
  var Int server_laps := undefined
  var Str encoding := ""
  while not s:atend and { var Str l := s:readline ; l<>"" }
    if (l parse "sign-md5:" any:(var Str encoded))
      back := base64_decode:encoded
    eif (l parse "seed-rc4:" any:(var Str encoded))
      server_seed := base64_decode:encoded
    eif (l parse "laps-rc4:" (var Int i))
      server_laps := i
    eif (l parse "encoding:" any:(var Str enc)) and (enc="deflate" or enc="zlib")
      encoding := enc
      log trace encoding+" encoding accepted."
  log trace "secured client: new connection from " (shunt client_site<>"" "site "+client_site "user "+client_user) " to " server_site
  if server_seed="" or server_laps=undefined
    log trace "wrong server seed or laps."
    return failure
  # retreive the shared secret with this client (may be empty if they never talked together or the sever discarded it)
  var Str key
  if client_site<>""
    key := name_secret_database:data:host:client_site:session:server_site:key
    if key=""
      key := site_secret_database:data:site:client_site:session:server_site:key
  eif client_user<>""
    key := uncipher user_secret_database:data:user:client_user:session:server_site:key password
  # send MD5 digest of server seed + shared secret
  s writeline "sign-md5: "+base64_encode:(string_md5_binary_signature server_seed+key)
  s writeline "" ; s flush anytime
  s writeline ""
  if back<>(string_md5_binary_signature key+client_seed) or key=""
    # 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_site client_site client_user password log
    if key=""
      log trace "failed to exchange a shared key."
      return failure
  log trace "session opened (" key:len ")."
  var Link:SecuredStreamDriver drv :> new SecuredStreamDriver
  if (flags .and. out)<>0
    rc4_init drv:write_ctx server_seed+key+client_seed client_laps
  if (flags .and. in)<>0
    rc4_init drv:read_ctx client_seed+key+server_seed server_laps
  if client_site<>""
    drv local_site := client_site
  eif client_user<>""
    drv local_user := client_user
  drv remote_site := server_site
  drv security_level := min (rsa_nbbits site:server_site:public_key) (shunt client_site<>"" (rsa_nbbits site:client_site:public_key) (rsa_nbbits user:client_user:public_key))
  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 "null:" 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 SecuredFileSystem 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))
    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+noautopost)
      if s=failure
        log trace "Failed to connect to " s:name
        return (failure "failed to listen TCP port "+string:port)
    # receive the client seed
    var Str server_site := ""
    var Str client_site := ""
    var Str client_user := ""
    var Str client_seed := ""
    var Int client_laps := undefined
    var CBool query_client := false
    var CBool query_server := false
    var Str encoding := ""
    while not s:atend and { var Str l := s:readline ; l<>"" }
      if (l parse "server-site:" any:(var Str encoded))
        server_site := base64_decode encoded
      eif backward_compatibility and (l parse "server-user:" any:(var Str encoded))
        server_site := base64_decode encoded
      eif (l parse "client-site:" any:(var Str encoded))
        client_site := base64_decode encoded
      eif (l parse "client-user:" any:(var Str encoded))
        client_user := base64_decode encoded
      eif (l parse "seed-rc4:" any:(var Str encoded))
        client_seed := base64_decode encoded
      eif (l parse "laps-rc4:" (var Int i))
        client_laps := i
      eif (l parse "query-client-key")
        query_client := true
      eif (l parse "query-server-key")
        query_server := true
      eif (l parse "encoding:" any:(var Str enc)) and (enc="deflate" or enc="zlib")
        encoding := enc
    if query_client
      if client_site<>""
        var Str client_public := name_database:data:host:client_site public_key
        if client_public=""
          client_public := site:client_site public_key
        s writeline "client-key: "+client_public
      else
        var Str client_public := user:client_user public_key
        s writeline "client-key: "+client_public
    if query_server
      var Str server_public := name_database:data:host:server_site public_key
      if server_public<>""
        if not (server_public parse word:"rsa" _ any:(var Str part1a) _ any ) or not (name_secret_database:data:host:server_site:private_key parse word:"rsa" _ any:(var Str part1b) _ any) or part1a<>part1b
          server_public := "corrupted key"
      else
        server_public := site:server_site public_key
        if server_public<>""
          if not (server_public parse word:"rsa" _ any:(var Str part1a) _ any ) or not (site_secret_database:data:site:server_site:private_key parse word:"rsa" _ any:(var Str part1b) _ any) or part1a<>part1b
            server_public := "corrupted key"
      s writeline "server-key: "+server_public
    if encoding<>""
      s writeline "encoding: "+encoding
    log trace "info" "secured server: connection from " (shunt client_site<>"" "site "+client_site "user "+client_user) " to site " server_site
    if client_seed="" or client_laps=undefined
      log trace "wrong client seed or laps."
      return failure
    if name_secret_database:data:host:server_site:private_key="" and site_secret_database:data:site:server_site:private_key=""
      log trace "no private key for " server_site
      return failure
    # send server seed
    var Str server_seed := random_seed server_seed_bits\8
    var Int server_laps := server_rc4_laps
    s writeline "seed-rc4: "+base64_encode:server_seed
    s writeline "laps-rc4: "+string:server_laps
    # retreive the shared secret with this client (may be empty if they never talked together or the sever discarded it)
    var Str key := name_secret_database:data:host:server_site:session:(shunt client_site<>"" client_site client_user):key
    if key=""
      key := site_secret_database:data:site:server_site:session:(shunt client_site<>"" client_site client_user):key
    # send MD5 digest of shared secret + client seed
    s writeline "sign-md5: "+base64_encode:(string_md5_binary_signature key+client_seed)
    s writeline "" ; s flush anytime
    # wait for the MD5 digest of server seed + shared secret
    var Str back := ""
    while not s:atend and { var Str l := s:readline ; l<>"" }
      if (l parse "sign-md5:" any:(var Str encoded))
        back := base64_decode encoded
    if back<>(string_md5_binary_signature server_seed+key) or key=""
      # the MD5 was wrong or there was no shared secret: we must negotiate a new one using RSA keys
      log trace "info" "secured server: needs to exchange a shared key."
      part exchange "exchange secret keys"
        key := server_exchange_key s server_site client_site client_user log
      if key=""
        log trace "failed to exchange a shared key."
        return failure
    log trace "success" "secured server: session opened (" key:len ")."
    var Link:SecuredStreamDriver drv :> new SecuredStreamDriver
    if (flags .and. out)<>0
      rc4_init drv:write_ctx client_seed+key+server_seed server_laps
    if (flags .and. in)<>0
      rc4_init drv:read_ctx server_seed+key+client_seed client_laps
    drv local_site := server_site
    if client_site<>""
      drv remote_site := client_site
    eif client_user<>""
      drv remote_user := client_user
    drv security_level := min (rsa_nbbits site:server_site:public_key) (shunt client_site<>"" (rsa_nbbits site:client_site:public_key) (rsa_nbbits user:client_user:public_key))
    log trace "bits" "secured server: security level is " drv:security_level " bits"
    drv s :> s
    if encoding<>""
      log trace "encoding" "secured server: encoding is " encoding
      drv encoding := encoding
      var Link:Stream zs :> new Stream
      if (zs open "null:" 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 "connection" "secured channel " server_site " <- " (shunt client_site<>"" "site "+client_site "user "+client_user)
    status := open_server_channel port log options flags stream support
  eif (name parse "//" any:(var Str server_site) "/user/" (var Int port) "/" any:(var Str client_user) "/" any:(var Str password))
    status := open_client_channel server_site "" client_user password port log options flags stream support
  eif (name parse "//" any:(var Str server_site) "/site/" (var Int port) "/" any:(var Str client_site))
    status := open_client_channel server_site client_site "" "" port log options flags stream support
  eif backward_compatibility and (name parse "//" any:(var Str site) "/client/" (var Int port) "/" any:(var Str server_site) "/" any:(var Str client_user) "/" any:(var Str password)) and site=server_site
    status := open_client_channel server_site client_site client_user password port log options flags stream support
  else
    status := failure


method fs query filename options flags info -> status
  arg_rw SecuredFileSystem fs ; arg Str filename options ; arg Int flags ; arg_rw FileInfo info ; arg ExtendedStatus status
  if backward_compatibility and (filename parse "//" any:(var Str site) "/client/" (var Int port) "/" any:(var Str server_site) "/" any:(var Str client_user) "/" any:(var Str password))
    (var Stream s) open "tcp://"+site+"/client/"+string:port "" in+out+(flags .and. safe+noautopost)
    if s=failure
      return failure
    s writeline "server-site: "+base64_encode:server_site
    s writeline "client-user: "+base64_encode:client_user
    s writeline "query-server-key"
    s writeline "query-client-key"
    s writeline ""
    var Str answer := ""
    while not s:atend and { var Str l := s:readline ; l<>"" }
      if (l parse "server-key:" any:(var Str encoded))
        answer += " server_key "+string:encoded
      eif (l parse "client-key:" any:(var Str encoded))
        answer += " client_key "+string:encoded
    info options := answer 1 answer:len
    status := shunt answer<>"" success failure
  else
    status := failure


gvar SecuredFileSystem secured_file_system
pliant_multi_file_system mount "channel:" "" "" secured_file_system
pliant_multi_file_system mount "zchannel:" "" "zlib" secured_file_system


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


type NullStreamDriver
  void
StreamDriver maybe NullStreamDriver

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

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


type NullFileSystem
  void
FileSystem maybe NullFileSystem

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

gvar NullFileSystem null_file_system
pliant_multi_file_system mount "null:" "" null_file_system


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


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

export '. channel_support'