paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-15 20:29:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Gitlab client + example

Browse Source
This commit is contained in:
Michaël Van Canneyt 2021-08-08 15:22:33 +02:00
parent 58044c9632
commit c5a128fae7
9 changed files with 4175 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
packages/fpmake_add.inc
View File

@ -146,4 +146,5 @@
add_vclcompat(ADirectory+IncludeTrailingPathDelimiter('vcl-compat')); add_vclcompat(ADirectory+IncludeTrailingPathDelimiter('vcl-compat'));
add_qlunits(ADirectory+IncludeTrailingPathDelimiter('qlunits')); add_qlunits(ADirectory+IncludeTrailingPathDelimiter('qlunits'));
add_mustache(ADirectory+IncludeTrailingPathDelimiter('fcl-mustache')); add_mustache(ADirectory+IncludeTrailingPathDelimiter('fcl-mustache'));
add_gitlab(ADirectory+IncludeTrailingPathDelimiter('gitlab'));

1
packages/fpmake_proc.inc
View File

@ -828,3 +828,4 @@ begin
end; end;
{$include ide/fpmake.pp} {$include ide/fpmake.pp}
{$include gitlab/fpmake.pp}

3037
packages/gitlab/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

102
packages/gitlab/Makefile.fpc Normal file
View File

@ -0,0 +1,102 @@
#
# Makefile.fpc for running fpmake
#
[package]
name=gitlab
version=3.3.1
[require]
packages=rtl fpmkunit fcl-base fcl-net fcl-web fcl-json
[install]
fpcpackage=y
[default]
fpcdir=../..
[prerules]
FPMAKE_BIN_CLEAN=$(wildcard ./fpmake$(SRCEXEEXT))
ifdef OS_TARGET
FPC_TARGETOPT+=--os=$(OS_TARGET)
endif
ifdef CPU_TARGET
FPC_TARGETOPT+=--cpu=$(CPU_TARGET)
endif
LOCALFPMAKE=./fpmake$(SRCEXEEXT)
[rules]
# Do not pass the Makefile's unit and binary target locations. Fpmake uses it's own.
override FPCOPT:=$(filter-out -FU%,$(FPCOPT))
override FPCOPT:=$(filter-out -FE%,$(FPCOPT))
# Do not pass the package-unitdirectories. Fpmake adds those and this way they don't apear in the .fpm
override FPCOPT:=$(filter-out $(addprefix -Fu,$(COMPILER_UNITDIR)),$(FPCOPT))# Compose general fpmake-parameters
# Compose general fpmake-parameters
ifdef FPMAKEOPT
FPMAKE_OPT+=$(FPMAKEOPT)
endif
FPMAKE_OPT+=--localunitdir=../..
FPMAKE_OPT+=--globalunitdir=..
FPMAKE_OPT+=$(FPC_TARGETOPT)
FPMAKE_OPT+=$(addprefix -o ,$(FPCOPT))
FPMAKE_OPT+=--compiler=$(FPC)
FPMAKE_OPT+=-bu
.NOTPARALLEL:
fpmake$(SRCEXEEXT): fpmake.pp
$(FPCFPMAKE) fpmake.pp $(FPMAKE_SKIP_CONFIG) $(addprefix -Fu,$(COMPILER_FPMAKE_UNITDIR)) $(FPCMAKEOPT) $(OPT)
all: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT)
smart: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -XX -o -CX
release: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dRELEASE
debug: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dDEBUG
# If no fpmake exists and (dist)clean is called, do not try to build fpmake, it will
# most often fail because the dependencies are cleared.
# In case of a clean, simply do nothing
ifeq ($(FPMAKE_BIN_CLEAN),)
clean:
else
clean:
$(FPMAKE_BIN_CLEAN) clean $(FPMAKE_OPT)
endif
# In case of a distclean, perform an 'old'-style distclean. This to avoid problems
# when the package is compiled using fpcmake prior to running this clean using fpmake
ifeq ($(FPMAKE_BIN_CLEAN),)
distclean: $(addsuffix _distclean,$(TARGET_DIRS)) fpc_cleanall
else
distclean:
ifdef inUnix
{ $(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT); if [ $$? != "0" ]; then { echo Something wrong with fpmake exectable. Remove the executable and call make recursively to recover.; $(DEL) $(FPMAKE_BIN_CLEAN); $(MAKE) fpc_cleanall; }; fi; }
else
$(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT)
endif
-$(DEL) $(LOCALFPMAKE)
endif
cleanall: distclean
install: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR)
else
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR)
endif
# distinstall also installs the example-sources and omits the location of the source-
# files from the fpunits.cfg files.
distinstall: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
else
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
endif
zipinstall: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX)
zipdistinstall: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) -ie -fsp 0
zipsourceinstall: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=share/src/fpc-\$$\(PACKAGEVERSION\)/$(INSTALL_FPCSUBDIR)/\$$\(PACKAGEDIRECTORY\)
else
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=source\\$(INSTALL_FPCSUBDIR)\\\$$\(PACKAGEDIRECTORY\)
endif

169
packages/gitlab/examples/closetodo/closetodo.lpr Normal file
View File

@ -0,0 +1,169 @@
program closetodo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
Classes, SysUtils, CustApp, fpjson, gitlabclient,opensslsockets, jsonparser ;
type
{ TCloseTodoApplication }
TCloseTodoApplication = class(TCustomApplication)
private
FConfig : TGitlabConfig;
FClient : TGitLabClient;
FIDS : TStrings;
FQuiet : Boolean;
procedure CloseTodo(aID: int64);
procedure DoClientLog(Sender: TObject; const aMessage: string);
procedure DoResource(Sender: TObject; aPage, aIndex, aCount: Integer; aObject: TJSONObject; aContinue: Boolean);
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure Usage(const aError : String); virtual;
end;
{ TCloseTodoApplication }
procedure TCloseTodoApplication.DoResource(Sender: TObject; aPage, aIndex,
aCount: Integer; aObject: TJSONObject; aContinue: Boolean);
Var
aData : TJSONData;
Msg,aState : String;
aBugID,aBugIID,aProjectID : Int64;
begin
Msg:=Format('[Page %d [%d/%d]: ',[aPage,aIndex,aCount]);
aProjectID:=0;
aBugID:=0;
aBugIID:=0;
aState:='';
aData:=aObject.FindPath('target.state');
if Assigned(aData) then
aState:=aData.AsString;
aData:=aObject.FindPath('project.id');
if Assigned(aData) then
aProjectID:=aData.AsInt64;
aData:=aObject.FindPath('target.id');
if Assigned(aData) then
aBugID:=aData.AsInt64;
aData:=aObject.FindPath('target.iid');
if Assigned(aData) then
aBugIID:=aData.Asint64;
DoClientLog(Self,Msg+Format('Project: %d, bug: %d, bug iid: %d, state : %s',[aProjectID,aBugID,aBugIID,aState]));
if SameText(aState,'closed') then
begin
if (FConfig.ProjectID=0) or (aProjectID=FConfig.ProjectID) then
FIDS.Add(IntToStr(aObject.Get('id',Int64(0))));
end
end;
procedure TCloseTodoApplication.CloseTodo(aID : int64);
Var
aResource : String;
begin
if (aID=-1) then
exit;
aResource:=Format('todos/%d/mark_as_done',[aID]);
Writeln('Posting ',aResource);
FClient.CreateResource(aResource,Nil);
end;
procedure TCloseTodoApplication.DoClientLog(Sender: TObject;
const aMessage: string);
begin
if not FQuiet then
Writeln(aMessage);
end;
procedure TCloseTodoApplication.DoRun;
var
ErrorMsg: String;
ListFN,ConfigFN : String;
I : Integer;
begin
Terminate;
ErrorMsg:=CheckOptions('hc:l:q', ['help','config:','list:','quiet']);
if (ErrorMsg<>'') or HasOption('h','help') then
begin
Usage(ErrorMsg);
Exit;
end;
FQuiet:=HasOption('q','quiet');
ConfigFN:=GetOptionValue('c','config');
if ConfigFN='' then
begin
Usage('Need gitlab config file');
Exit;
end;
if not FileExists(ConfigFN)then
begin
Usage('Gitlab config file "'+ConfigFN+'" does not exist');
Exit;
end;
FConfig.LoadFromFile(ConfigFN,'');
FClient.Config:=FConfig;
ListFN:=GetOptionValue('l','list');
if FileExists(ListFN)then
FIDS.LoadFromFile(ListFN)
else
begin
FClient.ForEachResource('todos',['action','assigned','state','pending'],@DoResource);
FIDS.SaveToFile(ListFN);
end;
For I:=0 to FIDS.Count-1 do
CloseTodo(StrToInt64Def(FIDS[i],-1));
Writeln(Format('Closed %d todos',[FIDS.Count]));
// stop program loop
Terminate;
end;
constructor TCloseTodoApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FConfig.Reset;
FClient:=TGitLabClient.Create;
FClient.OnLog:=@DoClientLog;
StopOnException:=True;
FIDS:=TStringList.Create;
end;
destructor TCloseTodoApplication.Destroy;
begin
FreeAndNil(FIDS);
FreeAndNil(FClient);
inherited Destroy;
end;
procedure TCloseTodoApplication.Usage(const aError: String);
begin
if (aError<>'') then
Writeln('Error : ',aError);
Writeln('Usage: ', ExeName, ' [options]');
Writeln('Where [Options] is one or more of:');
Writeln('-h --help This help');
Writeln('-c --config=FILE Config file');
Writeln('-l --list=FILE if file exists, read todo IDS from list. If file does not exist, write file after querying gitlab');
Writeln('-q --quiet less messages');
end;
var
Application: TCloseTodoApplication;
begin
Application:=TCloseTodoApplication.Create(nil);
Application.Title:='Close Todos Application';
Application.Run;
Application.Free;
end.

170
packages/gitlab/examples/closetodo/closetodo.pp Normal file
View File

@ -0,0 +1,170 @@
program closetodo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
Classes, SysUtils, CustApp, fpjson, gitlabclient,opensslsockets, jsonparser ;
type
{ TCloseTodoApplication }
TCloseTodoApplication = class(TCustomApplication)
private
FConfig : TGitlabConfig;
FClient : TGitLabClient;
FIDS : TStrings;
FQuiet : Boolean;
procedure CloseTodo(aID: int64);
procedure DoClientLog(Sender: TObject; const aMessage: string);
procedure DoResource(Sender: TObject; aPage, aIndex, aCount: Integer; aObject: TJSONObject; aContinue: Boolean);
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure Usage(const aError : String); virtual;
end;
{ TCloseTodoApplication }
procedure TCloseTodoApplication.DoResource(Sender: TObject; aPage, aIndex,
aCount: Integer; aObject: TJSONObject; aContinue: Boolean);
Var
aData : TJSONData;
Msg,aState : String;
aBugID,aBugIID,aProjectID : Int64;
begin
Msg:=Format('[Page %d [%d/%d]: ',[aPage,aIndex,aCount]);
aProjectID:=0;
aBugID:=0;
aBugIID:=0;
aState:='';
aData:=aObject.FindPath('target.state');
if Assigned(aData) then
aState:=aData.AsString;
aData:=aObject.FindPath('project.id');
if Assigned(aData) then
aProjectID:=aData.AsInt64;
aData:=aObject.FindPath('target.id');
if Assigned(aData) then
aBugID:=aData.AsInt64;
aData:=aObject.FindPath('target.iid');
if Assigned(aData) then
aBugIID:=aData.Asint64;
DoClientLog(Self,Msg+Format('Project: %d, bug: %d, bug iid: %d, state : %s',[aProjectID,aBugID,aBugIID,aState]));
if SameText(aState,'closed') then
begin
if (FConfig.ProjectID=0) or (aProjectID=FConfig.ProjectID) then
FIDS.Add(IntToStr(aObject.Get('id',Int64(0))));
end
end;
procedure TCloseTodoApplication.CloseTodo(aID : int64);
Var
aResource : String;
begin
if (aID=-1) then
exit;
aResource:=Format('todos/%d/mark_as_done',[aID]);
Writeln('Posting ',aResource);
FClient.CreateResource(aResource,Nil);
end;
procedure TCloseTodoApplication.DoClientLog(Sender: TObject;
const aMessage: string);
begin
if not FQuiet then
Writeln(aMessage);
end;
procedure TCloseTodoApplication.DoRun;
var
ErrorMsg: String;
ListFN,ConfigFN : String;
I : Integer;
begin
Terminate;
ErrorMsg:=CheckOptions('hc:l:q', ['help','config:','list:','quiet']);
if (ErrorMsg<>'') or HasOption('h','help') then
begin
Usage(ErrorMsg);
Exit;
end;
FQuiet:=HasOption('q','quiet');
ConfigFN:=GetOptionValue('c','config');
if ConfigFN='' then
begin
Usage('Need gitlab config file');
Exit;
end;
if not FileExists(ConfigFN)then
begin
Usage('Gitlab config file "'+ConfigFN+'" does not exist');
Exit;
end;
FConfig.LoadFromFile(ConfigFN,'');
FClient.Config:=FConfig;
ListFN:=GetOptionValue('l','list');
if FileExists(ListFN)then
FIDS.LoadFromFile(ListFN)
else
begin
FClient.ForEachResource('todos',['action','assigned','state','pending'],@DoResource);
if ListFN<>'' then
FIDS.SaveToFile(ListFN);
end;
For I:=0 to FIDS.Count-1 do
CloseTodo(StrToInt64Def(FIDS[i],-1));
Writeln(Format('Closed %d todos',[FIDS.Count]));
// stop program loop
Terminate;
end;
constructor TCloseTodoApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FConfig.Reset;
FClient:=TGitLabClient.Create;
FClient.OnLog:=@DoClientLog;
StopOnException:=True;
FIDS:=TStringList.Create;
end;
destructor TCloseTodoApplication.Destroy;
begin
FreeAndNil(FIDS);
FreeAndNil(FClient);
inherited Destroy;
end;
procedure TCloseTodoApplication.Usage(const aError: String);
begin
if (aError<>'') then
Writeln('Error : ',aError);
Writeln('Usage: ', ExeName, ' [options]');
Writeln('Where [Options] is one or more of:');
Writeln('-h --help This help');
Writeln('-c --config=FILE Config file');
Writeln('-l --list=FILE if file exists, read todo IDS from list. If file does not exist, write file after querying gitlab');
Writeln('-q --quiet less messages');
end;
var
Application: TCloseTodoApplication;
begin
Application:=TCloseTodoApplication.Create(nil);
Application.Title:='Close Todos Application';
Application.Run;
Application.Free;
end.

8
packages/gitlab/examples/closetodo/sample.cfg Normal file
View File

@ -0,0 +1,8 @@
[Gitlab]
; API key to use, this determines what user will be used
APIKey=yourveryownsecretapikey
; You can leave this empty, then all todos for closed bugs will be marked done
; If set, only todos for the given project are treated
ProjectID=123

50
packages/gitlab/fpmake.pp Normal file
View File

@ -0,0 +1,50 @@
{$ifndef ALLPACKAGES}
{$mode objfpc}{$H+}
program fpmake;
uses fpmkunit;
{$endif ALLPACKAGES}
procedure add_gitlab(const ADirectory: string);
Const
TargetsWithfpWeb = [linux,beos,haiku,freebsd,netbsd,openbsd,darwin,iphonesim,ios,solaris,win32,win64,wince,aix,dragonfly];
Var
T : TTarget;
P : TPackage;
begin
With Installer do
begin
P:=AddPackage('gitlab');
P.ShortName:='gitlab';
P.Directory:=ADirectory;
P.Version:='3.3.1';
P.OSes := TargetsWithfpWeb;
if Defaults.CPU=jvm then
P.OSes := P.OSes - [java,android];
P.Dependencies.Add('fcl-base');
P.Dependencies.Add('fcl-json');
P.Dependencies.Add('fcl-net');
P.Dependencies.Add('fcl-web');
P.Dependencies.Add('openssl',AllUnixOSes+AllWindowsOSes);
P.Author := 'FreePascal development team';
P.License := 'LGPL with modification, ';
P.HomepageURL := 'www.freepascal.org';
P.Email := '';
P.Description := 'Simple client for Gitlab v4 API';
P.NeedLibC:= false;
P.SourcePath.Add('src');
T:=P.Targets.addUnit('gitlabclient.pas');
end;
end;
{$ifndef ALLPACKAGES}
begin
add_gitlab('');
Installer.Run;
end.
{$endif ALLPACKAGES}

637
packages/gitlab/src/gitlabclient.pas Normal file
View File

@ -0,0 +1,637 @@
unit gitlabclient;
{$mode ObjFPC}{$H+}
{$modeswitch advancedrecords}
interface
uses
Classes, SysUtils, inifiles, fpjson, fpwebclient, fphttpwebclient, httpprotocol;
Const
LongThrottleSleep = 60 * 1000; // One minute
MaxSleepCount = 5; // max times to sleep when consecutive 429s
SGitlabClient = 'Gitlab'; // Default section
DefaultGitURL = 'https://gitlab.com/api/v4/';
DefaultGitKey = ''; // API Key, default none
DefaultProjectID = 0; // Gitlab Project ID, default none
Type
EGitLab = Class(Exception);
{ TGitlabConfig }
TGitlabConfig = Record
BaseURL : String;
APIkey : String;
ProjectID : Int64;
Procedure Reset;
Procedure LoadFromFile(const aFileName,aSection : String);
Procedure LoadFromIni(aIni : TCustomInifile; const aSection : String);
end;
{ TGitLabClient }
TLogEvent = Procedure (Sender : TObject; Const aMessage : string) of object;
TResourceCallback = procedure (Sender : TObject; aPage,aIndex,aCount : Integer; aObject : TJSONObject; aContinue : Boolean) of object;
TGitLabClient = class(TObject)
private
FConfig: TGitlabConfig;
FClient : TAbstractWebClient;
FOnLog: TLogEvent;
FSudo: String;
procedure setconfig(AValue: TGitlabConfig);
Protected
procedure DoLog(const aMessage : string); overload;
procedure DoLog(const aFmt : string; aArgs : Array of const); overload;
function CreateRequest(aResult: TStream): TWebClientRequest;
function CreateURL(aName: string; aParams: array of string; useSUDO : Boolean = False): String;
procedure DoResourceRequest(aVerb, aName: String; aSrc: TStream; ADest: TStream; aContentType: String);
procedure CreateResource(aName : String; aSrc : TStream; ADest : TStream; aContentType : String = '');
procedure UpdateResource(aName : String; aSrc : TStream; ADest : TStream; aContentType : String = '');
public
Constructor Create; overload;
Constructor Create(const aConfig : TGitlabConfig); overload;
Destructor destroy; override;
function GetProjectResourceURL(aResource: string): String;
function GetResourceURL(aResource: string): String;
// Upload file. URL is relative to baseURL, gets upload appended.
// Return markdown
Function UploadFile(const aURL,aLocalFileName,aRemoteFileName : String) : TJSONStringType;
// Return JSON string
function UploadFileRaw(const aURL,aLocalFileName,aRemoteFileName: string): TJSONStringType;
// Return JSON Object
Function UploadFileObject(const aURL,aLocalFileName,aRemoteFileName : String) : TJSONObject;
// Create
Function CreateResourceRaw(aName : String; aObj : TJSONObject) : TJSONStringType;
Function CreateResourceObject(aName : String; aObj : TJSONObject) : TJSONObject;
Function CreateResource(aName : String; aObj : TJSONObject) : Int64;
// update
Function UpdateResourceRaw(aName : String; aObj : TJSONObject) : TJSONStringType;
Function UpdateResource(aName : String; aObj : TJSONObject) : Int64;
Function UpdateResourceObject(aName : String; aObj : TJSONObject) : TJSONObject;
// Get
Function GetSingleResource(aName : String; aParams : array of string) : TJSONObject;
Function GetResourceList(aName : String; aParams : array of string) : TJSONArray;
Procedure GetResource(aName : String; aParams : array of string; aResult : TStream);
Function ForEachResource(aResource : String; aParams : array of string; CallBack : TResourceCallback) : Integer;
// Delete
Procedure DeleteResource(aName : String);
// Properties
Property Config : TGitlabConfig Read FConfig write setconfig;
Property OnLog : TLogEvent Read FOnLog Write FOnLog;
// use SUDO
Property Sudo : String Read FSudo Write FSudo;
end;
implementation
{ TGitlabConfig }
procedure TGitlabConfig.Reset;
begin
BaseURL:=DefaultGitURL;
APIKey:=DefaultGitKey;
ProjectID:=DefaultProjectID;
end;
procedure TGitlabConfig.LoadFromFile(const aFileName, aSection: String);
Var
aIni : TMemIniFile;
begin
aIni:=TMemIniFile.Create(aFileName);
try
LoadFromIni(aIni,aSection);
finally
aIni.Free;
end;
end;
procedure TGitlabConfig.LoadFromIni(aIni: TCustomInifile; const aSection: String);
Var
S : String;
begin
S:=aSection;
if S='' then
S:=SGitlabClient;
BaseURL:=aIni.ReadString(S,'BaseURL',BaseURL);
APIkey:=aIni.ReadString(S,'APIKey',APIKey);
ProjectID:=aIni.ReadInt64(S,'ProjectID',ProjectID);
end;
constructor TGitLabClient.Create;
begin
FClient:=TFPHTTPWebClient.Create(Nil);
end;
constructor TGitLabClient.Create(const aConfig: TGitlabConfig);
begin
Create;
Config:=aConfig;
end;
destructor TGitLabClient.destroy;
begin
FreeAndNil(FClient);
inherited destroy;
end;
function TGitLabClient.UploadFile(const aURL, aLocalFileName,
aRemoteFileName: String): TJSONStringType;
Var
Obj : TJSONObject;
begin
Obj:=UploadFileObject(aURL,aLocalFileName,aRemoteFilename);
try
Result:=Obj.Get('markdown','');
finally
Obj.Free;
end;
end;
function TGitLabClient.UploadFileRaw(const aURL, aLocalFileName,
aRemoteFileName: string): TJSONStringType;
Const
CRLF = #13#10;
Var
S, Sep : string;
SS,SR : TRawByteStringStream;
AStream : TFileStream;
begin
Sep:=Format('%.8x_multipart_boundary',[Random($ffffff)]);
aStream:=Nil;
SR:=Nil;
SS:=TRawByteStringStream.Create('');
try
AStream:=TFileStream.Create(aLocalFileName,fmOpenRead);
S:='--'+Sep+CRLF;
s:=s+Format('Content-Disposition: form-data; name="%s"; filename="%s"'+CRLF,['file',aRemoteFileName]);
s:=s+'Content-Type: application/octet-string'+CRLF+CRLF;
SS.WriteBuffer(S[1],Length(S));
AStream.Seek(0, soFromBeginning);
SS.CopyFrom(AStream,AStream.Size);
S:=CRLF+'--'+Sep+'--'+CRLF;
SS.WriteBuffer(S[1],Length(S));
SS.Position:=0;
SR:=TRawByteStringStream.Create('');
DoResourceRequest('POST',aURL,SS,SR,'multipart/form-data; boundary='+Sep);
Result:=SR.DataString;
finally
SR.Free;
SS.Free;
aStream.Free;
end;
end;
function TGitLabClient.UploadFileObject(const aURL, aLocalFileName,
aRemoteFileName: String): TJSONObject;
var
aJSON : TJSONStringType;
D : TJSONData;
begin
aJSON:=UploadFileRaw(aURL,aLocalFileName,aRemoteFileName);
try
D:=GetJSON(aJSON);
Result:=D as TJSONObject;
except
on E : Exception do
begin
D.Free;
E.Message:='Invalid JSON returned by upload of '+aLocalFileName+': '+E.Message;
Raise;
end;
end;
end;
function TGitLabClient.CreateResourceRaw(aName: String; aObj: TJSONObject): TJSONStringType;
Var
Src,Dest : TStringStream;
begin
Dest:=nil;
Src:=Nil;
if Assigned(aObj) then
Src:=TStringStream.Create(aObj.asJSON);
try
Dest:=TStringStream.Create('');
CreateResource(aName,Src,Dest,'application/json');
Result:=Dest.DataString;
finally
Src.Free;
Dest.Free;
end;
end;
function TGitLabClient.CreateResourceObject(aName: String; aObj: TJSONObject): TJSONObject;
Var
S : TJSONStringType;
D : TJSONData;
begin
S:=CreateResourceRaw(aName,aObj);
try
D:=GetJSON(S);
Result:=D as TJSONObject;
except
on E : Exception do
begin
D.Free;
E.Message:='Invalid JSON returned by Create of '+aName+': '+E.Message;
Raise;
end;
end;
end;
function TGitLabClient.CreateResource(aName: String; aObj: TJSONObject): Int64;
Var
Obj : TJSONObject;
begin
Obj:=CreateResourceObject(aName,aObj);
try
Result:=Obj.Get('id',Int64(-1));
finally
Obj.Free;
end;
end;
function TGitLabClient.UpdateResourceRaw(aName: String; aObj: TJSONObject
): TJSONStringType;
Var
Src,Dest : TStringStream;
begin
Dest:=nil;
Src:=TStringStream.Create(aObj.asJSON);
try
Dest:=TStringStream.Create('');
UpdateResource(aName,Src,Dest,'application/json');
Result:=Dest.DataString;
finally
Src.Free;
Dest.Free;
end;
end;
function TGitLabClient.UpdateResource(aName: String; aObj: TJSONObject): Int64;
Var
Obj : TJSONObject;
begin
Obj:=UpdateResourceObject(aName,aObj);
try
Result:=Obj.Get('id',Int64(-1));
finally
Obj.Free;
end;
end;
function TGitLabClient.UpdateResourceObject(aName: String; aObj: TJSONObject
): TJSONObject;
Var
S : TJSONStringType;
D : TJSONData;
begin
S:=UpdateResourceRaw(aName,aObj);
try
D:=GetJSON(S);
Result:=D as TJSONObject;
except
on E : Exception do
begin
D.Free;
E.Message:='Invalid JSON returned by Create of '+aName+': '+E.Message;
Raise;
end;
end;
end;
function TGitLabClient.GetSingleResource(aName: String; aParams: array of string
): TJSONObject;
Var
S : TStream;
D : TJSONData;
begin
D:=NIl;
S:=TMemoryStream.Create;
try
GetResource(aName,aParams,S);
try
if S.Size>0 then
D:=GetJSON(S);
if (D<>Nil) and Not (D is TJSONObject) then
Raise EGitlab.Create('Not a JSON object '+D.AsJSON);
Result:=D as TJSONObject;
except
On E :Exception do
E.Message:='Error getting resource'+aName+': '+E.Message;
end;
finally
S.Free;
end;
end;
function TGitLabClient.GetResourceList(aName: String; aParams: array of string
): TJSONArray;
Var
S : TStream;
D : TJSONData;
begin
D:=NIl;
S:=TMemoryStream.Create;
try
GetResource(aName,aParams,S);
try
D:=GetJSON(S);
if Not (D is TJSONArray) then
Raise EGitlab.Create('Not a JSON array '+D.AsJSON);
Result:=D as TJSONArray;
except
On E :Exception do
begin
E.Message:='Error getting resource'+aName+': '+E.Message;
Raise;
end;
end;
finally
S.Free;
end;
end;
procedure TGitLabClient.setconfig(AValue: TGitlabConfig);
begin
FConfig:=AValue;
end;
procedure TGitLabClient.DoLog(const aMessage: string);
begin
If Assigned(FOnLog) then
FOnLog(Self,aMessage);
end;
procedure TGitLabClient.DoLog(const aFmt: string; aArgs: array of const);
begin
DoLog(Format(aFmt,aArgs));
end;
function TGitLabClient.CreateRequest(aResult: TStream): TWebClientRequest;
begin
Result:=FClient.CreateRequest;
Result.Headers.Values['Authorization']:='Bearer '+FConfig.APIkey;
Result.ResponseContent:=aResult;
end;
function TGitLabClient.CreateURL(aName: string; aParams: array of string; useSUDO : Boolean = False): String;
Var
I : Integer;
begin
Result:=IncludeHTTPPathDelimiter(FConfig.BaseURL);
Result:=Result+aName;
if (Length(aParams) mod 2<>0) then
Raise EGitLab.Create('URL Parameters must come in key=value pairs');
I:=0;
While I<Length(aParams)-1 do
begin
if I=0 then
Result:=Result+'?'
else
Result:=Result+'&';
Result:=Result+HTTPEncode(aParams[i])+'='+HTTPEncode(aParams[i+1]);
inc(I,2);
end;
if UseSUDO and (Sudo<>'') then
begin
if Length(aParams)=0 then
Result:=Result+'?'
else
Result:=Result+'&';
Result:=Result+'sudo='+HTTPEncode(SUDO);
end;
end;
procedure TGitLabClient.CreateResource(aName: String; aSrc: TStream;
ADest: TStream; aContentType: String);
begin
DoResourceRequest('POST',aName,aSrc,aDest,aContentType);
end;
procedure TGitLabClient.DoResourceRequest(aVerb,aName: String; aSrc: TStream;
ADest: TStream; aContentType: String);
Function StreamToContent(S : TStream) : string;
begin
Result:='';
if (S<>Nil) then
With TStringStream.Create('') do
try
CopyFrom(S,0);
Result:=DataString;
S.Position:=0;
finally
Free;
end;
end;
Var
aRequest : TWebClientRequest;
aResponse : TWebClientResponse;
aContent,aMsg,aURL : String;
aSleepTime : Integer;
aSleepCount : integer;
aTryCount : Integer;
UseSUDO, ExitLoop : Boolean;
begin
aSleepCount:=1;
aTryCount:=0;
aResponse:=Nil;
aRequest:=CreateRequest(aDest);
try
if (aSrc<>Nil) then
begin
if (aContentType='') then
aContentType:='application/json';
aRequest.Headers.Values['Content-Type']:=aContentType;
aRequest.Content.CopyFrom(aSrc,0);
end;
repeat
inc(aTryCount);
ExitLoop:=True;
UseSUDO:=False; // (Sudo<>'') and Not SameText(aVerb,'GET')
aURL:=CreateURL(aName,[],UseSUDO);
DoLog('URL : %s %s',[aVerb,aURL]);
// Reset for loop
FreeAndNil(aResponse);
if Assigned(aSrc) then
aRequest.Content.Position:=0;
// Go !
aResponse:=FClient.ExecuteRequest(aVerb,aURL,aRequest);
// Throttle hit ?
if aResponse.StatusCode=429 then
begin
aSleepTime:=LongThrottleSleep*aSleepCount;
DoLog('API Throttle limit reached. Waiting %d seconds',[aSleepTime div 1000]);
sleep(aSleepTime);
Inc(aSleepCount);
ExitLoop:=(aSleepCount>MaxSleepCount);
end
else if aResponse.StatusCode=409 then
begin
if aTryCount>1 then
DoLog('Duplicate ID found at try %d, ignoring.',[aTryCount])
else
DoLog('Duplicate ID found at first try, ignoring anyway.');
ExitLoop:=True;
end
else if aResponse.StatusCode=500 then
begin
aSleepTime:=LongThrottleSleep*aSleepCount;
DoLog('Retry 500 error. Waiting %d seconds',[aSleepTime div 1000]);
sleep(aSleepTime);
Inc(aSleepCount);
ExitLoop:=(aSleepCount>MaxSleepCount);
end
else if (UseSUDO and ((aResponse.StatusCode=403) or (aResponse.StatusCode=404))) then
begin
DoLog('SUDO request for %s failed, switching to non-sudo request',[Sudo]);
ExitLoop:=False;
Sudo:='';
end;
until ExitLoop;
if (aResponse.StatusCode div 100)<>2 then
begin
aContent:=StreamToContent(aSrc);
aMsg:=StreamToContent(aDest);
Raise EGitLab.CreateFmt('Failed to %s URL "%s" : %d (%s):'+sLineBreak+'%s'+sLineBreak+'Request Content:'+sLineBreak+'%s',[aVerb,aURL,aResponse.StatusCode,aResponse.StatusText,aMsg,aContent]);
end
else
begin
if aSleepCount > 1 then
DoLog('Success after %d retries', [aSleepCount-1]);
end;
if assigned(aDest) then
aDest.Position:=0;
finally
aRequest.Free;
aResponse.Free;
end;
end;
procedure TGitLabClient.UpdateResource(aName: String; aSrc: TStream;
ADest: TStream; aContentType: String);
begin
DoResourceRequest('PUT',aName,aSrc,aDest,aContentType);
end;
procedure TGitLabClient.GetResource(aName: String; aParams: array of string;
aResult: TStream);
Var
aRequest : TWebClientRequest;
aResponse : TWebClientResponse;
aURL : String;
begin
aURL:=CreateURL(aName,aParams);
aResponse:=Nil;
aRequest:=CreateRequest(aResult);
try
aResponse:=FClient.ExecuteRequest('GET',aURL,aRequest);
if (aResponse.StatusCode div 100)<>2 then
Raise EGitLab.CreateFmt('Failed to get URL "%s" : %d (%s)',[aURL,aResponse.StatusCode,aResponse.StatusText]);
aResult.Position:=0;
finally
aRequest.Free;
aResponse.Free;
end;
end;
function TGitLabClient.GetProjectResourceURL(aResource: string): String;
begin
Result:=GetResourceURL(Format('projects/%d/%s/',[FConfig.ProjectID,aResource]))
end;
function TGitLabClient.GetResourceURL(aResource: string): String;
begin
Result:= IncludeHTTPPathDelimiter(FConfig.BaseURL)+aResource;
end;
function TGitLabClient.ForEachResource(aResource: String; aParams: array of string;
CallBack: TResourceCallback): Integer;
Var
Resources : TJSONArray;
aLen,aTotalCount,i,aCount,aPage : Integer;
aID : Int64;
baseURL : String;
tParams : Array of string;
aContinue : Boolean;
begin
setLength(tParams,Length(aParams)+4);
aLen:=Length(aParams);
For I:=0 to Length(aParams)-1 do
tParams[i]:=aParams[I];
tParams[aLen]:='per_page';
tParams[aLen+1]:='100';
Result:=0;
aPage:=1;
Repeat
tParams[aLen+2]:='page';
tParams[aLen+3]:=IntToStr(aPage);
Resources:=GetResourceList(aResource,tParams);
try
aCount:=Resources.Count;
aContinue:=True;
I:=0;
While aContinue and (I<aCount) do
begin
CallBack(Self,aPage,I,aCount,Resources.Objects[i],aContinue);
Inc(I);
Inc(Result);
end;
finally
Resources.Free;
end;
inc(aPage);
until (aCount<100) or Not aContinue;
end;
procedure TGitLabClient.DeleteResource(aName: String);
begin
DoResourceRequest('DELETE',aName,Nil,Nil,'');
end;
end.