Patch title: Release 84 bulk changes
Abstract:
File: /pliant/protocol/webdav/server.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
submodule "/pliant/protocol/common/tcp_server.pli"
module "/pliant/util/encoding/date.pli"

type DavServer
  tcp_server_fields "WebDAV" 8080
  field Str root <- "file:/pub/"
TcpServer maybe DavServer

function unhexa s -> i
  arg Str s ; arg Int i
  i := 0
  for (var Int j) 0 s:len-1
    var Int c := s:j number
    if c>="0":0:number and c<="9":0:number
      i := i*16+(c-"0":0:number)
    eif c>="A":0:number and c<="F":0:number
      i := i*16+(c-"A":0:number+10)
    eif c>="a":0:number and c<="f":0:number
      i := i*16+(c-"a":0:number+10)
    eif c=" ":number
      void
    else
      return undefined

method server service s
  arg_rw DavServer server ; arg_rw Stream s
  while not s:atend

    var Str query := s readline ; console "<= " query eol
    var List:Str query_options := var List:Str empty_list
    var Int length := undefined ; var CBool chunked := false
    var Int depth := undefined
    while { var Str opt := s readline ; console "-- " opt eol ; opt<>"" }
      query_options += opt
      if (opt parse "Content-Length" ":" (var Int i))
        length := i
      if (opt parse "Transfer-Encoding" ":" "chunked" any)
        chunked := true
      if (opt parse "Depth" ":" (var Int i))
        depth := i
    var Str query_body := ""
    if chunked
      console "<- "
      part read_chunk
        var Str csize := s readline
        var Int length := unhexa csize
        if length=undefined
          console "unsupported chunk length" eol
          return
        var Str chunk := repeat length " "
        s raw_read chunk:characters chunk:len ; console chunk 
        query_body += chunk
        var Str eoc := s readline
        if csize<>"0"
          restart read_chunk
      console eol
    eif length<>undefined
      query_body := repeat length " "
      s raw_read query_body:characters query_body:len ; console "<- " query_body eol

    var Str answer := ""
    var List:Str answer_options := var List:Str empty_list
    var Str answer_body := ""

    if (query parse word:"OPTIONS" _ any:(var Str path) _ word:"HTTP" "/" any)
      answer := "HTTP/1.1 200 OK"
      answer_options += "DAV: 1"
    eif (query parse word:"PROPFIND" _ any:(var Str path) _ word:"HTTP" "/" any) and (path 0 1)="/"
      var List:Str props :=  var List:Str empty_list ; var List:Str prop_ns :=  var List:Str empty_list
      var (Dictionary Str Str) namespaces := var (Dictionary Str Str) empty_dict
      var CBool prop := false
      var Str all := query_body
      while (all parse "<" any:(var Str tag) ">" any:(var Str remain))
        if (tag parse any:(var Str base) _ any:(var Str options))
          tag := base
        else
          options := ""
        if (tag parse any:(var Str base) "/")
          tag := base
        if (tag parse any ":" any:(var Str base))
          tag := base
        if tag="/prop"
          prop := false
        var Str ns := options option "xmlns=" Str
        if not exists:(namespaces first ns)
          namespaces insert ns "ns"+(string namespaces:size)
        if prop
          props += tag ; prop_ns += ns
        if tag="prop"
          prop := true
        all := remain
        while (all 0 1)="[cr]" or (all 0 1)="[lf]" or (all 0 1)=" "
          all := all 1 all:len
      (var Array:FileInfo files) size := 0
      if depth=0
        files += file_query server:root+(path 1 path:len) extended
        files:0 name := ""
      else
        files := file_list server:root+(path 1 path:len) extended+directories+relative
      answer := "HTTP/1.1 207 Multi-Status"
      answer_body += "<?xml version=[dq]1.0[dq] encoding=[dq]utf-8[dq]?>[lf]"
      answer_body += "<D:multistatus xmlns:D=[dq]DAV:[dq]"
      each pns namespaces
        answer_body += " xmlns:"+pns+"=[dq]"+(shunt (namespaces key pns)<>"" (namespaces key pns) "DAV:")+"[dq]"
      answer_body +=">[lf]"
      for (var Int i) 0 files:size-1
        answer_body += "<D:response>[lf]"
        answer_body += "<D:href>"+path+files:i:name+"</D:href>[lf]"
        for (var Int lap) 0 1
          answer_body += "<D:propstat>[lf]"
          answer_body += "<D:prop>[lf]"
          var Pointer:Str p :> props first ; var Pointer:Str pns :> prop_ns first
          while exists:p
            var Str ns := namespaces pns ; var Str tag := ""
            if p="resourcetype"
              tag := (shunt files:i:is_directory or depth=0 "<D:resourcetype><D:collection/></D:resourcetype>" "<D:resourcetype/>")
            eif p="getcontentlength"
              if not (files:i:is_directory or depth=0)
                tag := "<D:getcontentlength>"+(string files:i:size)+"</D:getcontentlength>"
            eif p="getlastmodified"
              tag := "<D:getlastmodified>"+(rfc1123_date files:i:datetime)+"</D:getlastmodified>"
            if tag<>""
              if lap=0
                answer_body += tag+"[lf]"
            else
              if lap=1
                answer_body += "<"+ns+":"+p+"/>[lf]"
            p :> props next p ; pns :> prop_ns next pns
          answer_body += "</D:prop>[lf]"
          answer_body += "<D:status>HTTP/1.1 "+(shunt lap=0 "200 OK" "404 Not Found")+"</D:status>[lf]"
          answer_body += "</D:propstat>[lf]"
        answer_body += "</D:response>[lf]"
      answer_body += "</D:multistatus>[lf]"
    else
      return

    answer_options += "Content-Length: "+(string answer_body:len)
    answer_options += "Connection: Keep-Alive"
    answer_options += ""
    s writeline answer ; console "=> " answer eol
    var Pointer:Str p :> answer_options first
    while exists:p
      s writeline p ; console "-- " p eol
      p :> answer_options next p
    s writechars answer_body ; console "-> " answer_body eol
    

define_tcp_server DavServer webdav_server
export webdav_server '. root'