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'
|