{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Implementation of the WebDAV protocol.       | }
{ |                                                             | }
{ |                                                             | }
{ |   Copyright (C) - 2012 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code dstributed under MIT license.                 | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }

{$INCLUDE GMCompilerSettings.inc}

unit GMWebDAV;

interface

uses {$IFDEF JEDIAPI}{$ELSE}Windows,{$ENDIF}
     GMActiveX, GMStrDef, GMCollections, GMIntf, GMCommon, GMSockets, GMHttp
     {$IFDEF TLS_SUPPORT},GMOpenSSL{$ENDIF};

type

  TGMHttpRequestWithErrorResponseParsing = class(TGMHttpClientRequest)
   protected
    function BuildErrorMsgPostfixFromResponseContent(const AResponseContent: ISequentialStream): TGMString; override;
  end;


  TGMDAVEnunDepth = (dedSelf, dedChildren, dedInfinite);

  TGMWebDAVClient = class;

  IGMWebDAVClient = interface(IUnknown)
    ['{3ED3D533-611D-43DA-A300-9676DBFD5C03}']
    function Obj: TGMWebDAVClient;
  end;

  TGMWebDAVClient = class(TGMRefCountedObj, IGMWebDAVClient)
   protected
    FProtocol, FHost, FPort: TGMString;
    FHttpSession: IGMHttpClientSession;
    {$IFDEF TLS_SUPPORT}
//  FAskCanceled: IUnknown;
    FCertMessagesShown: IGMIntfCollection;
    FCertMessageEmitter: IUnknown;
    {$ENDIF}

    function Protocol: TGMString;
    function EncodePath(const APath: TGMString): AnsiString;
    function DecodePath(const APath: AnsiString): TGMString;
    {$IFDEF DEBUG}
    procedure XmldumpLine(const ALine: TGMString);
    {$ENDIF}

//  procedure ExecuteRequest(const AMethod, );
    function CreateHttpRequest: IGMHttpClientRequest;
    function ExecuteHttpRequest(const ARequest: IGMHttpClientRequest; const AMethod, APath, AProtocol: TGMString; const ARequestContent:
        IStream = nil; const AAdditionalHeaders: TGMNameAndStrValArray = []; const AOnProgressProc: TGMOnProgressProc = nil; const AUploadBuffersize:
        LongInt = -cDfltUiResponseMS): ISequentialStream;

   public
//  constructor Create(const ARefLifeTime: Boolean = True); overload; override;
    constructor Create(const AProtocol, AHost, APort: TGMString; const AAskCanceled, AAskLoginData: IUnknown; const ARefLifeTime: Boolean = True); reintroduce; overload;
//  destructor Destroy; override;
    function Obj: TGMWebDAVClient;
//  procedure ShowCertificateVerifyStatus(const AHost: TGMString; const ACertCode: Int64);
//  function GetHttpLoginData(ALoginData: PGMHttpLoginData): HResult; stdcall;
    procedure EnumEntries(const AEnumSink: IUnknown; const APath: TGMString = ''; const AEnumParam: Pointer = nil;  const AEnumItemKind: LongInt = 0; APropFindXMl: TGMString = '');
    procedure CreateCollection(const APath: TGMString);
    procedure DeleteCollection(const APath: TGMString);
    procedure DeleteFile(const APath: TGMString);
    procedure RenameCollection(const AExistingNamePath, ANewNamePath: TGMString);
    function GetDownloadStream(const AFilePath: TGMString): ISequentialStream;
    procedure UploadStream(const AFilePath: TGMString; const AContent: IStream; const ASizeInBytes: Int64; const ALastModUTC: TDateTime;
                           const AAdditionalHeaders: TGMNameAndStrValArray = []; const AOnProgressProc: TGMOnProgressProc = nil;
                           const AUploadBuffersize: LongInt = -cDfltUiResponseMS);
    procedure SetProperties(const APath: TGMString; const AProperties: IGMIntfCollection; const AXmlNameSpace: TGMString = '');

    property HttpSession: IGMHttpClientSession read FHttpSession;
  end;


  EGMWebDAVException = class(EGMException);


const

  cGMWebDAVAgent = 'GM-WebDAV/1.0';

  cStrXMLUtf8 = '<?xml version="1.0" encoding="utf-8"?>';
  cDavPropFindAllXml = '<D:propfind xmlns:D="DAV:"><D:allprop/></D:propfind>';

  cDavDepth = 'Depth';
  cDavInfinity = 'infinity';
  cDavDestination = 'Destination';
  cDavOverwrirte = 'Overwrite';

  cDavXmlMultiStatus = 'multistatus';
  cDavXmlResponse = 'response';
  cDavPropHRef = 'href';
  cDavPropStat = 'propstat';
  cDavProp = 'prop';
  cDavXmlStatus = 'status';
  cDavPropResourceType = 'resourcetype';
  cDavPropIsHidden = 'ishidden';
  cDavPropCollection = 'collection';
  cDavPropLastMod = 'getlastmodified';
  cDavPropContentLength = 'getcontentlength';

  cHttpContentXml = 'text/xml';  // 'application/xml; charset="utf-8"'

  cStrLastModTimeFmt = '';


implementation

uses GMXml, GMINetBase;

resourcestring

  RStrFailSetDAVPropFmt = 'Failed to set WebDAV property "%s" for';


{ ------------------------- }
{ ---- Global Routines ---- }
{ ------------------------- }

function PathTerm(const APath: TGMString): TGMString;
begin
  if APath <> '' then
   begin
    Result := GMStripRight(APath, scHttpDirSeparator);
    Result := Result + scHttpDirSeparator;
   end;
end;


{ ------------------------------------------------ }
{ ---- TGMHttpRequestWithErrorResponseParsing ---- }
{ ------------------------------------------------ }

function TGMHttpRequestWithErrorResponseParsing.BuildErrorMsgPostfixFromResponseContent(const AResponseContent: ISequentialStream): TGMString;
begin
  Result := GMExtractAnyTextResponse(AResponseContent, GMGetINetHeaderStrValue(ReceivedHeaders, cHttpContentType));
end;


{ ------------------------- }
{ ---- TGMWebDAVClient ---- }
{ ------------------------- }

constructor TGMWebDAVClient.Create(const AProtocol, AHost, APort: TGMString; const AAskCanceled, AAskLoginData: IUnknown; const ARefLifeTime: Boolean); // const ATlsAttributes: TGMTlsAttributes;
begin
  Create(ARefLifeTime);
  FProtocol := AProtocol;
  FHost := AHost;
  FPort := APort;
  {$IFDEF TLS_SUPPORT}
//FAskCanceled := AAskCanceled;
  FCertMessageEmitter := TGMCertMessageEmitter.Create(AAskCanceled);
  {$ENDIF}
  FHttpSession := TGMHttpClientSession.Create(AAskCanceled, AAskLoginData, {$IFDEF TLS_SUPPORT}FCertMessageEmitter{$ELSE}nil{$ENDIF});
end;

//destructor TGMWebDAVClient.Destroy;
//begin
//inherited;
//end;

function TGMWebDAVClient.Obj: TGMWebDAVClient;
begin
  Result := Self;
end;

function TGMWebDAVClient.Protocol: TGMString;
begin
  Result := scStrHttp;
end;

function TGMWebDAVClient.EncodePath(const APath: TGMString): AnsiString;
begin
  Result := GMStringToUtf8(APath);
end;

function TGMWebDAVClient.DecodePath(const APath: AnsiString): TGMString;
begin
  Result := GMUtf8ToString(APath);
end;

//function TGMWebDAVClient.GetHttpLoginData(ALoginData: PGMHttpLoginData): HResult;
//var getLoginData: IGMGetHttpLoginData;
//begin
//if ALoginData = nil then begin Result := E_INVALIDARG; Exit; end;
//if FAskLoginData = nil then begin Result := E_NOTIMPL; Exit; end;
//Result := FAskLoginData.QueryInterface(IGMGetHttpLoginData, getLoginData);
//if not GMHrSucceeded(Result) then Exit;
//Result := getLoginData.GetHttpLoginData(ALoginData);
//if not GMHrSucceeded(Result) then Exit;
////FUserName := ALoginData.UserName;
////FPassword := ALoginData.Password;
//end;

{$IFDEF DEBUG}
procedure TGMWebDAVClient.XmldumpLine(const ALine: TGMString);
begin
  GMTrace(ALine, tpXml);
end;
{$ENDIF}

function TGMWebDAVClient.CreateHttpRequest: IGMHttpClientRequest;
begin
//Result := TGMHttpClientRequest.Create(cGMWebDAVAgent);
  Result := TGMHttpRequestWithErrorResponseParsing.Create(cGMWebDAVAgent);
end;

function TGMWebDAVClient.ExecuteHttpRequest(const ARequest: IGMHttpClientRequest; const AMethod, APath, AProtocol: TGMString;
    const ARequestContent: IStream; const AAdditionalHeaders: TGMNameAndStrValArray; const AOnProgressProc: TGMOnProgressProc;
    const AUploadBuffersize: LongInt): ISequentialStream;
begin
  if ARequest = nil then Exit;

  //if not HttpSession.IsTransportLayerConnected then HttpSession.ConnectTransportLayer(FProtocol, FHost, FPort);

  Result := HttpSession.ExecuteRequest(ARequest, GMBuildUri(FProtocol, '', '', FHost, FPort, APath), AMethod,
                                       ARequestContent, AAdditionalHeaders, AOnProgressProc, AUploadBuffersize).ResponseContent;
end;

procedure TGMWebDAVClient.EnumEntries(const AEnumSink: IUnknown; const APath: TGMString; const AEnumParam: Pointer;
  const AEnumItemKind: Integer; APropFindXMl: TGMString);
var httpRequest: IGMHttpClientRequest; requestContent: IStream; xml: IGMXmlTree; node, childNode: IGMXmlNode;
    responseContent: ISequentialStream; tellIntf: IGMTellEnumIntf; it: IGMIterator; unkNode: IUnknown;

  procedure ReadMultiStatisResponse(const AResponseNode: IGMXmlNode);
  var httpVersion, httpStatus, httpReason, valStr: TGMString; propStatNode, propNode, hrefNode, attrNode: IGMXmlNode; attributes: IGMIntfCollection;
      it, it2: IGMIterator; unkNode, unkNode2: IUnknown;
    procedure AttributesFromXmlNode(const AXmlNode: IGMXmlNode; const AAttributes: IGMIntfCollection);
    var node: IGMXmlNode;
    begin
      if (AXmlNode = nil) or (AAttributes = nil) or (Length(AXmlNode.Obj.Name) <= 0) then Exit;

      if not GMSameText(AXmlNode.Obj.Name, cDavPropResourceType) then
       AAttributes.Add(TGMNameAndValueObj.Create(AXmlNode.Obj.Name, AXmlNode.Obj.StrValue))
      else
       begin
        if AXmlNode.Obj.FindSubNodeIntoVar(cDavPropCollection, nil, node, 1) then
         AAttributes.Add(TGMNameAndValueObj.Create(AXmlNode.Obj.Name, cDavPropCollection))
        else
         AAttributes.Add(TGMNameAndValueObj.Create(AXmlNode.Obj.Name, ''));
       end;
    end;
  begin
    if (AResponseNode = nil) or (not GMSameText(AResponseNode.Obj.Name, cDavXmlResponse)) then Exit;

    hrefNode := AResponseNode.Obj.CheckFindSubNode(cDavPropHRef, nil, 1);

    it := AResponseNode.Obj.SubNodes.CreateIterator;
//  for i:=0 to AResponseNode.Obj.SubNodes.Count-1 do
    while it.NextEntry(unkNode) do
     if GMQueryInterface(unkNode, IGMXmlNode, propStatNode) then
      begin
//     propStatNode := AResponseNode.SubNodes[i];
       if not GMSameText(propStatNode.Obj.Name, cDavPropStat) then Continue;

       valStr := GMCheckFindXmlSubValue(propStatNode, cDavXmlStatus);
       GMParseHttpStartLine(valStr, httpVersion, httpStatus, httpReason);
       if GMIsHttpSuccessStatus(GMHttpStatusCodeFromString(httpStatus)) then
        begin
         attributes := TGMIntfArrayCollection.Create(False, True, GMCompareByName, True);
         attributes.Add(TGMNameAndValueObj.Create(hrefNode.Obj.Name, DecodePath(GMUriDecode(hrefNode.Obj.StrValue))));

         propNode := propStatNode.Obj.CheckFindSubNode(cDavProp, nil, 1);

         it2 := propNode.Obj.SubNodes.CreateIterator;
         while it2.NextEntry(unkNode2) do
          if GMQueryInterface(unkNode2, IGMXmlNode, attrNode) then AttributesFromXmlNode(attrNode, attributes);

//       for j:=0 to propNode.SubNodes.Count-1 do AttributesFromXmlNode(propNode.SubNodes[j], attributes);

         tellIntf.TellEnumIntf(Self, AEnumItemKind, attributes, AEnumParam);
        end;
      end;
  end;
begin
  if not GMQueryInterface(AEnumSink, IGMTellEnumIntf, tellIntf) then Exit;

  httpRequest := CreateHttpRequest;

  if Length(APropFindXMl) <= 0 then APropFindXMl := cDavPropFindAllXml;
  requestContent := TGMAnsiStringIStream.Create(cStrXMLUtf8 + CRLF + APropFindXMl);

  //
  // TRacing of request content is done inside http request object via IGMGetText interface of request content stream
  //
  //if vfGMDoTracing then GMTrace(GMGetIntfText(requestContent), tpXml); // <- Would appaer bofre headers ..

  GMAddINetHeader(httpRequest.Obj.HeadersToSend, cDavDepth, 1);
//httpRequest.Obj.AddRequestHeader(cDavDepth, 1);

  responseContent := ExecuteHttpRequest(httpRequest, 'PROPFIND', EncodePath(PathTerm(APath)), Protocol, requestContent, [InitRGMNameAndStrValue(cHttpContentType, cHttpContentXml)]);
  xml := TGMXmlTree.CreateRead(responseContent);

  if vfGMDoTracing then GMTraceXml(xml);

  if xml.Obj.RootNode.Obj.FindSubNodeIntoVar(cDavXmlMultiStatus, nil, node, 1) then
   begin
    it := node.Obj.SubNodes.CreateIterator;
    while it.NextEntry(unkNode) do
     if GMQueryInterface(unkNode, IGMXmlNode, childNode) then ReadMultiStatisResponse(childNode);
   end;

// for i:=0 to node.SubNodes.Count-1 do ReadMultiStatisResponse(node.SubNodes[i]);
end;

procedure TGMWebDAVClient.CreateCollection(const APath: TGMString);
var httpRequest: IGMHttpClientRequest; responseContent: ISequentialStream;
begin
  httpRequest := CreateHttpRequest;
  responseContent := ExecuteHttpRequest(httpRequest, 'MKCOL', EncodePath(PathTerm(APath)), Protocol);
  GMConsumeStreamContent(responseContent);
end;

procedure TGMWebDAVClient.DeleteCollection(const APath: TGMString);
var httpRequest: IGMHttpClientRequest; responseContent: ISequentialStream;
begin
  httpRequest := CreateHttpRequest;
//httpRequest.Obj.AddRequestHeader(cDavDepth, cDavInfinity);
  responseContent := ExecuteHttpRequest(httpRequest, 'DELETE', EncodePath(PathTerm(APath)), Protocol);
  GMConsumeStreamContent(responseContent);
end;

procedure TGMWebDAVClient.DeleteFile(const APath: TGMString);
var httpRequest: IGMHttpClientRequest; responseContent: ISequentialStream;
begin
  httpRequest := CreateHttpRequest;
  responseContent := ExecuteHttpRequest(httpRequest, 'DELETE', EncodePath(APath), Protocol);
  GMConsumeStreamContent(responseContent);
end;

procedure TGMWebDAVClient.RenameCollection(const AExistingNamePath, ANewNamePath: TGMString);
var httpRequest: IGMHttpClientRequest; responseContent: ISequentialStream;
begin
  httpRequest := CreateHttpRequest;
//httpRequest.Obj.AddRequestHeader(cDavDepth, cDavInfinity);
  GMAddINetHeader(httpRequest.Obj.HeadersToSend, cDavDestination, GMUriEncode(EncodePath(GMBuildUri(LowerCase(Protocol), '', '', FHost, '', PathTerm(ANewNamePath), '', ''))));
//httpRequest.Obj.AddRequestHeader(cDavDestination, GMUriEncode(EncodePath(GMBuildUri(LowerCase(Protocol), '', '', FHost, '', PathTerm(ANewNamePath), ''))));

//httpRequest.Obj.AddRequestHeader(cDavOverwrirte, 'F');
  GMAddINetHeader(httpRequest.Obj.HeadersToSend, cDavOverwrirte, 'F');

  responseContent := ExecuteHttpRequest(httpRequest, 'MOVE', EncodePath(PathTerm(AExistingNamePath)), Protocol);
  GMConsumeStreamContent(responseContent);
end;

function TGMWebDAVClient.GetDownloadStream(const AFilePath: TGMString): ISequentialStream;
var httpRequest: IGMHttpClientRequest;
begin
  httpRequest := CreateHttpRequest;
  Result := ExecuteHttpRequest(httpRequest, cHttpMethodGET, EncodePath(AFilePath), Protocol);
end;

procedure TGMWebDAVClient.UploadStream(const AFilePath: TGMString; const AContent: IStream; const ASizeInBytes: Int64; const ALastModUTC: TDateTime;
  const AAdditionalHeaders: TGMNameAndStrValArray; const AOnProgressProc: TGMOnProgressProc; const AUploadBuffersize: LongInt);
var httpRequest: IGMHttpClientRequest; responseContent: ISequentialStream;
begin
  httpRequest := CreateHttpRequest;

//httpRequest.Obj.AddRequestHeader(cHttpContentLength, IntToStr(ASizeInBytes));
  GMAddINetHeader(httpRequest.Obj.HeadersToSend, cHttpContentLength, GMIntToStr(ASizeInBytes));

//httpRequest.Obj.AddRequestHeader('Last-Modified', GMEncodeUtcToINetTime(ALastModUTC, Self));
  GMAddINetHeader(httpRequest.Obj.HeadersToSend, 'Last-Modified', GMEncodeUtcToINetTime(ALastModUTC, Self));

  responseContent := ExecuteHttpRequest(httpRequest, cHttpMethodPUT, EncodePath(AFilePath), Protocol, Acontent, AAdditionalHeaders, AOnProgressProc, AUploadBuffersize);
  GMConsumeStreamContent(responseContent);
end;

procedure TGMWebDAVClient.SetProperties(const APath: TGMString; const AProperties: IGMIntfCollection; const AXmlNameSpace: TGMString);
const cNSDav = 'D';
var httpRequest: IGMHttpClientRequest; requestContent: IStream; xml: IGMXmlTree;
    xmlNode, responseNode, propStatNode, valNode, node: IGMXmlNode; responseContent: ISequentialStream;
    propIt, it, it2: IGMIterator; unkProp, unkNode, unkNode2: IUnknown; name: IGMGetName; strVal: IGMGetStringValue;
    errMsg, errToken, valStr, httpVersion, httpStatus, httpReason, xmlNSProp: TGMString;
begin
  httpRequest := CreateHttpRequest;

  xml := TGMXmlTree.CreateWrite;

  xmlNode := GMCreateXmlNode(xml.Obj.RootNode, 'propertyupdate', '', cNSDav);
  xmlNode.Obj.Attributes.Add(xmlNode.Obj.AttributeCreateClass.Create('xmlns:'+cNSDav, '"DAV:"'));
  if Length(AXmlNameSpace) >= 0 then
   begin
    xmlNSProp := 'P';
    xmlNode.Obj.Attributes.Add(xmlNode.Obj.AttributeCreateClass.Create('xmlns:'+xmlNSProp, AXmlNameSpace));
   end
  else xmlNSProp := cNSDav;

  xmlNode := GMCreateXmlNode(xmlNode, 'set', '', cNSDav);
  propIt := AProperties.CreateIterator;
  while propIt.NextEntry(unkProp) do
   if GMQueryInterface(unkProp, IGMGetName, name) and GMQueryInterface(unkProp, IGMGetStringValue, strVal) and (Length(name.Name) > 0) then
    begin
     propStatNode := GMCreateXmlNode(xmlNode, 'prop', '', cNSDav);
     GMCreateXmlNode(propStatNode, name.Name, strVal.StringValue, xmlNSProp);
    end;

  //
  // TRacing of request content is done inside http request object via IGMGetText interface of request content stream
  //
  //if vfGMDoTracing then GMTraceXml(xml); // <- Would appaer bofre headers ..

//requestContent := TGMMemoryIStream.Create;
  requestContent := TGMAnsiStringIStream.Create; // <- supports IGMGetText for tracing
  xml.Obj.SaveToStream(requestContent, '');
  GMSetIStreamAbsPos(requestContent, 0, {$I %CurrentRoutine%});

  responseContent := ExecuteHttpRequest(httpRequest, 'PROPPATCH', EncodePath(APath), Protocol, requestContent, [InitRGMNameAndStrValue(cHttpContentType, cHttpContentXml)]);
  xml := TGMXmlTree.CreateRead(responseContent);

  if vfGMDoTracing then GMTraceXml(xml);

  errMsg := '';
  if xml.Obj.RootNode.Obj.FindSubNodeIntoVar(cDavXmlMultiStatus, nil, xmlNode, 1) then
   begin
    it := xmlNode.Obj.SubNodes.CreateIterator;
//  for i:=0 to xmlNode.SubNodes.Count-1 do
    while it.NextEntry(unkNode) do
     if GMQueryInterface(unkNode, IGMXmlNode, responseNode) then
      begin
 //    responseNode := xmlNode.SubNodes[i];
       if not GMSameText(responseNode.Obj.Name, cDavXmlResponse) then Continue;

       it2 := responseNode.Obj.SubNodes.CreateIterator;
//     for j:=0 to responseNode.SubNodes.Count-1 do
       while it2.NextEntry(unkNode2) do
        if GMQueryInterface(unkNode2, IGMXmlNode, propStatNode) then
         begin
 //       propStatNode := responseNode.SubNodes[j];
          if not GMSameText(propStatNode.Obj.Name, cDavPropStat) then Continue;

          valStr := GMCheckFindXmlSubValue(propStatNode, cDavXmlStatus, nil, 1);
          GMParseHttpStartLine(valStr, httpVersion, httpStatus, httpReason);
          if not GMIsHttpSuccessStatus(GMHttpStatusCodeFromString(httpStatus)) then
           begin
            errToken := '';
            if propStatNode.Obj.FindSubNodeIntoVar(cDavProp, nil, valNode, 1) and GMQueryInterface(valNode.Obj.SubNodes.First, IGMXmlNode, node) then
               errToken := GMFormat(RStrFailSetDAVPropFmt, [node.Obj.Name]);

            if responseNode.Obj.FindSubNodeIntoVar(cDavPropHRef, nil, valNode, 1) then
               errToken := GMStringJoin(errToken, ' ', GMFormat('URI "%s"', [DecodePath(GMUriDecode(valNode.Obj.StrValue))]));

            errToken := GMStringJoin(errToken, ': ', GMBuildHttpErrorMsg(GMHttpStatusCodeFromString(httpStatus), httpReason));
            errMsg := GMstringJoin(errMsg, c2NewLine, errToken);
           end;
         end;
      end;
   end;

  if Length(errMsg) > 0 then raise EGMWebDAVException.ObjError(errMsg, Self, {$I %CurrentRoutine%});
end;


end.