mirror of
https://github.com/rejetto/hfs2.git
synced 2025-12-19 10:03:56 +01:00
https client support
This commit is contained in:
Massimo Melina
parent
18b7961d29
commit
c4ca0d2188
1
.gitignore
vendored
1
.gitignore
vendored
@ -8,6 +8,7 @@ win32/
|
||||
*.exe
|
||||
*.map
|
||||
*.tmp
|
||||
*.dll
|
||||
*.bak
|
||||
*.*-
|
||||
*.corrupted
|
||||
|
||||
@ -23,7 +23,8 @@ unit classesLib;
|
||||
interface
|
||||
|
||||
uses
|
||||
iniFiles, types, hslib, strUtils, sysUtils, classes, math, system.Generics.Collections;
|
||||
iniFiles, types, hslib, strUtils, sysUtils, classes, math, system.Generics.Collections,
|
||||
OverbyteIcsWSocket, OverbyteIcshttpProt;
|
||||
|
||||
type
|
||||
TfastStringAppend = class
|
||||
@ -189,6 +190,12 @@ type
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
ThttpClient = class(TSslHttpCli)
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor destroy;
|
||||
class function createURL(url:string):ThttpClient;
|
||||
end;
|
||||
|
||||
Ttlv = class
|
||||
protected
|
||||
cur, bound: integer;
|
||||
@ -214,6 +221,30 @@ implementation
|
||||
uses
|
||||
utilLib, main, windows, dateUtils, forms;
|
||||
|
||||
class function ThttpClient.createURL(url:string):ThttpClient;
|
||||
begin
|
||||
if startsText('https://', url)
|
||||
and not httpsCanWork() then
|
||||
exit(NIL);
|
||||
result:=ThttpClient.Create(NIL);
|
||||
result.URL:=url;
|
||||
end;
|
||||
|
||||
constructor ThttpClient.create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
followRelocation:=TRUE;
|
||||
agent:=HFS_HTTP_AGENT;
|
||||
SslContext := TSslContext.Create(NIL);
|
||||
end; // create
|
||||
|
||||
destructor ThttpClient.destroy;
|
||||
begin
|
||||
SslContext.free;
|
||||
SslContext:=NIl;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
constructor TperIp.create();
|
||||
begin
|
||||
limiter:=TspeedLimiter.create();
|
||||
@ -504,10 +535,7 @@ end; // reset
|
||||
function TtarStream.fsInit():boolean;
|
||||
begin
|
||||
if assigned(fs) and (fs.FileName = flist[cur].src) then
|
||||
begin
|
||||
result:=TRUE;
|
||||
exit;
|
||||
end;
|
||||
exit(TRUE);
|
||||
result:=FALSE;
|
||||
try
|
||||
freeAndNIL(fs);
|
||||
@ -1089,8 +1117,8 @@ function Ttlv.pop(var value:string; var raw:ansistring):integer;
|
||||
var
|
||||
n: integer;
|
||||
begin
|
||||
result:=-1;
|
||||
if isOver() then exit; // finished
|
||||
if isOver() then
|
||||
exit(-1); // finished
|
||||
result:=integer((@whole[cur])^);
|
||||
n:=Pinteger(@whole[cur+4])^;
|
||||
raw:=copy(whole, cur+8, n);
|
||||
@ -1109,10 +1137,7 @@ function Ttlv.down():boolean;
|
||||
begin
|
||||
// do we have anything to recur on?
|
||||
if (cur = 1) then
|
||||
begin
|
||||
result:=false;
|
||||
exit;
|
||||
end;
|
||||
exit(FALSE);
|
||||
// push into the stack
|
||||
if (stackTop = length(stack)) then // space over
|
||||
setLength(stack, stackTop+10); // make space
|
||||
@ -1129,10 +1154,7 @@ end; // down
|
||||
function Ttlv.up():boolean;
|
||||
begin
|
||||
if stackTop = 0 then
|
||||
begin
|
||||
result:=false;
|
||||
exit;
|
||||
end;
|
||||
exit(FALSE);
|
||||
dec(stackTop);
|
||||
bound:=stack[stackTop];
|
||||
dec(stackTop);
|
||||
|
||||
24
main.dfm
24
main.dfm
@ -2,7 +2,7 @@ object mainFrm: TmainFrm
|
||||
Left = 293
|
||||
Top = 219
|
||||
Caption = 'HFS ~ HTTP File Server'
|
||||
ClientHeight = 483
|
||||
ClientHeight = 436
|
||||
ClientWidth = 879
|
||||
Color = clBtnFace
|
||||
Constraints.MinHeight = 260
|
||||
@ -218,7 +218,7 @@ object mainFrm: TmainFrm
|
||||
Left = 0
|
||||
Top = 83
|
||||
Width = 879
|
||||
Height = 400
|
||||
Height = 353
|
||||
Align = alClient
|
||||
BevelOuter = bvNone
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
@ -228,10 +228,11 @@ object mainFrm: TmainFrm
|
||||
Font.Style = []
|
||||
ParentFont = False
|
||||
TabOrder = 0
|
||||
ExplicitHeight = 400
|
||||
object splitV: TSplitter
|
||||
Left = 313
|
||||
Top = 0
|
||||
Height = 289
|
||||
Height = 242
|
||||
Beveled = True
|
||||
Constraints.MaxWidth = 3
|
||||
Constraints.MinWidth = 3
|
||||
@ -241,7 +242,7 @@ object mainFrm: TmainFrm
|
||||
end
|
||||
object splitH: TSplitter
|
||||
Left = 0
|
||||
Top = 289
|
||||
Top = 242
|
||||
Width = 879
|
||||
Height = 5
|
||||
Cursor = crVSplit
|
||||
@ -257,15 +258,16 @@ object mainFrm: TmainFrm
|
||||
Left = 316
|
||||
Top = 0
|
||||
Width = 563
|
||||
Height = 289
|
||||
Height = 242
|
||||
Align = alClient
|
||||
BevelOuter = bvNone
|
||||
TabOrder = 1
|
||||
ExplicitHeight = 289
|
||||
object logBox: TRichEdit
|
||||
Left = 0
|
||||
Top = 23
|
||||
Width = 563
|
||||
Height = 266
|
||||
Height = 219
|
||||
Align = alClient
|
||||
Font.Charset = ANSI_CHARSET
|
||||
Font.Color = clWindowText
|
||||
@ -282,6 +284,7 @@ object mainFrm: TmainFrm
|
||||
Zoom = 100
|
||||
OnChange = logBoxChange
|
||||
OnMouseDown = logBoxMouseDown
|
||||
ExplicitHeight = 266
|
||||
end
|
||||
object logTitle: TPanel
|
||||
Left = 0
|
||||
@ -557,16 +560,17 @@ object mainFrm: TmainFrm
|
||||
Left = 0
|
||||
Top = 0
|
||||
Width = 313
|
||||
Height = 289
|
||||
Height = 242
|
||||
Align = alLeft
|
||||
BevelOuter = bvNone
|
||||
Caption = 'filesPnl'
|
||||
TabOrder = 0
|
||||
ExplicitHeight = 289
|
||||
object filesBox: TTreeView
|
||||
Left = 0
|
||||
Top = 23
|
||||
Width = 313
|
||||
Height = 266
|
||||
Height = 219
|
||||
Align = alClient
|
||||
BevelInner = bvLowered
|
||||
BevelOuter = bvSpace
|
||||
@ -602,6 +606,7 @@ object mainFrm: TmainFrm
|
||||
OnMouseEnter = filesBoxMouseEnter
|
||||
OnMouseLeave = filesBoxMouseLeave
|
||||
OnMouseUp = filesBoxMouseUp
|
||||
ExplicitHeight = 266
|
||||
end
|
||||
object filesTitle: TPanel
|
||||
Left = 0
|
||||
@ -616,12 +621,13 @@ object mainFrm: TmainFrm
|
||||
end
|
||||
object connPnl: TPanel
|
||||
Left = 0
|
||||
Top = 294
|
||||
Top = 247
|
||||
Width = 879
|
||||
Height = 106
|
||||
Align = alBottom
|
||||
BevelOuter = bvNone
|
||||
TabOrder = 2
|
||||
ExplicitTop = 294
|
||||
object sbar: TStatusBar
|
||||
Left = 0
|
||||
Top = 87
|
||||
|
||||
82
main.pas
82
main.pas
@ -983,6 +983,7 @@ type
|
||||
procedure progFrmHttpGetUpdate(sender:TObject; buffer:pointer; Len:integer);
|
||||
procedure recalculateGraph();
|
||||
public
|
||||
procedure statusBarHttpGetUpdate(sender:TObject; buffer:pointer; Len:integer);
|
||||
procedure remove(node:Ttreenode=NIL);
|
||||
function setCfg(cfg:string; alreadyStarted:boolean=TRUE):boolean;
|
||||
function getCfg(exclude:string=''):string;
|
||||
@ -1268,10 +1269,7 @@ begin
|
||||
result:=NIL;
|
||||
if (account = NIL) or not account.enabled then exit;
|
||||
if shouldStop() then
|
||||
begin
|
||||
result:=account;
|
||||
exit;
|
||||
end;
|
||||
exit(account);
|
||||
i:=0;
|
||||
toCheck:=account.link;
|
||||
while i < length(toCheck) do
|
||||
@ -1280,10 +1278,7 @@ while i < length(toCheck) do
|
||||
inc(i);
|
||||
if (account = NIL) or not account.enabled then continue;
|
||||
if shouldStop() then
|
||||
begin
|
||||
result:=account;
|
||||
exit;
|
||||
end;
|
||||
exit(account);
|
||||
addUniqueArray(toCheck, account.link);
|
||||
end;
|
||||
end; // accountRecursion
|
||||
@ -1304,10 +1299,7 @@ begin
|
||||
result:=FALSE;
|
||||
if f = NIL then exit;
|
||||
if action = FA_ACCESS then
|
||||
begin
|
||||
result:=f.accessFor(cd);
|
||||
exit;
|
||||
end;
|
||||
exit(f.accessFor(cd));
|
||||
if f.isTemp() then
|
||||
f:=f.parent;
|
||||
if (action = FA_UPLOAD) and not f.isRealFolder() then exit;
|
||||
@ -1600,10 +1592,7 @@ var
|
||||
s:=commentMasks[i];
|
||||
mask:=chop('=', s);
|
||||
if fileMatch(mask, fn) then
|
||||
begin
|
||||
result:=s;
|
||||
exit;
|
||||
end;
|
||||
exit(s);
|
||||
end;
|
||||
result:='';
|
||||
end; // getCommentByMaskFor
|
||||
@ -2026,10 +2015,7 @@ fillChar(shfi, SizeOf(TShFileInfo), 0);
|
||||
// but it does not actually work without the expandFileName()
|
||||
shGetFileInfo( pchar(expandFileName(fn)), 0, shfi, SizeOf(shfi), SHGFI_SYSICONINDEX);
|
||||
if shfi.iIcon = 0 then
|
||||
begin
|
||||
result:=ICON_FILE;
|
||||
exit;
|
||||
end;
|
||||
exit(ICON_FILE);
|
||||
// as reported by official docs
|
||||
destroyIcon(shfi.hIcon);
|
||||
|
||||
@ -2136,10 +2122,7 @@ var
|
||||
begin
|
||||
for i:=0 to length(address2name) div 2-1 do
|
||||
if addressmatch(address2name[i*2+1], ip) then
|
||||
begin
|
||||
result:=address2name[i*2];
|
||||
exit;
|
||||
end;
|
||||
exit(address2name[i*2]);
|
||||
result:='';
|
||||
end; // localDNSget
|
||||
|
||||
@ -2196,10 +2179,7 @@ procedure updateDynDNS();
|
||||
begin
|
||||
s:=trim(s);
|
||||
if s = '' then
|
||||
begin
|
||||
result:='no reply';
|
||||
exit;
|
||||
end;
|
||||
exit('no reply');
|
||||
code:='';
|
||||
result:='successful';
|
||||
code:=trim(lowercase(getTill(' ',s)));
|
||||
@ -2207,9 +2187,8 @@ procedure updateDynDNS();
|
||||
for i:=1 to length(ERRORS) do
|
||||
if code = ERRORS[i].code then
|
||||
begin
|
||||
result:='error: '+ERRORS[i].msg;
|
||||
dyndns.active:=FALSE;
|
||||
exit;
|
||||
exit('error: '+ERRORS[i].msg);
|
||||
end;
|
||||
result:='unknown reply: '+s;
|
||||
end; // interpretResponse
|
||||
@ -2602,10 +2581,7 @@ end; // fixTreeStructure
|
||||
function Tfile.getParent():Tfile;
|
||||
begin
|
||||
if node = NIL then
|
||||
begin
|
||||
result:=NIL;
|
||||
exit;
|
||||
end;
|
||||
exit(NIL);
|
||||
if node.data <> self then // the tree structure is unreliable, at least on DISPLAYCHANGE event. This will workaround it
|
||||
fixTreeStructure(mainFrm.filesBox.Items[0]);
|
||||
if isTemp() then result:=nodeToFile(node)
|
||||
@ -2633,10 +2609,7 @@ var
|
||||
f: Tfile;
|
||||
begin
|
||||
if not isFolder() then
|
||||
begin
|
||||
result:=DLcount;
|
||||
exit;
|
||||
end;
|
||||
exit(DLcount);
|
||||
result:=0;
|
||||
if node = NIL then exit;
|
||||
n:=node.getFirstChild();
|
||||
@ -2714,8 +2687,8 @@ function Tfile.pathTill(root:Tfile=NIL; delim:char='\'):string;
|
||||
var
|
||||
f: Tfile;
|
||||
begin
|
||||
result:='';
|
||||
if self = root then exit;
|
||||
if self = root then
|
||||
exit('');
|
||||
result:=name;
|
||||
f:=parent;
|
||||
if isTemp() then
|
||||
@ -2914,8 +2887,7 @@ if not isTemp() then
|
||||
n:=n.getNextSibling();
|
||||
if (FA_LINK in f.flags) or f.isFolder()
|
||||
or not fileMatch(mask, f.name) or not fileExists(f.resource) then continue;
|
||||
result:=f;
|
||||
exit;
|
||||
exit(f);
|
||||
end;
|
||||
|
||||
if not isRealFolder() or not sysutils.directoryExists(resource) then exit;
|
||||
@ -2982,10 +2954,7 @@ if result >= 0 then exit;
|
||||
if isFile() then
|
||||
for i:=0 to length(iconMasks)-1 do
|
||||
if fileMatch(iconMasks[i].str, name) then
|
||||
begin
|
||||
result:=iconMasks[i].int;
|
||||
exit;
|
||||
end;
|
||||
exit(iconMasks[i].int);
|
||||
ic:=iconsCache.get(resource);
|
||||
if ic = NIL then
|
||||
begin
|
||||
@ -3089,7 +3058,6 @@ var
|
||||
begin
|
||||
result:=FALSE;
|
||||
if isFile() and isDLforbidden() then exit;
|
||||
result:=FALSE;
|
||||
f:=self;
|
||||
while assigned(f) do
|
||||
begin
|
||||
@ -3214,8 +3182,8 @@ end; // getSafeHost
|
||||
|
||||
function nodeIsLocked(n:Ttreenode):boolean;
|
||||
begin
|
||||
result:=FALSE;
|
||||
if (n = NIL) or (n.data = NIL) then exit;
|
||||
if (n = NIL) or (n.data = NIL) then
|
||||
exit(FALSE);
|
||||
result:=nodeToFile(n).isLocked();
|
||||
end; // nodeIsLocked
|
||||
|
||||
@ -3774,16 +3742,10 @@ begin
|
||||
result:=default;
|
||||
for i:=0 to length(mimeTypes) div 2-1 do
|
||||
if fileMatch(mimeTypes[i*2], fn) then
|
||||
begin
|
||||
result:=mimeTypes[i*2+1];
|
||||
exit;
|
||||
end;
|
||||
exit(mimeTypes[i*2+1]);
|
||||
for i:=0 to length(DEFAULT_MIME_TYPES) div 2-1 do
|
||||
if fileMatch(DEFAULT_MIME_TYPES[i*2], fn) then
|
||||
begin
|
||||
result:=DEFAULT_MIME_TYPES[i*2+1];
|
||||
exit;
|
||||
end;
|
||||
exit(DEFAULT_MIME_TYPES[i*2+1]);
|
||||
end; // name2mimetype
|
||||
|
||||
procedure Tmainfrm.getPage(sectionName:string; data:TconnData; f:Tfile=NIL; tpl2use:Ttpl=NIL);
|
||||
@ -12080,6 +12042,12 @@ with sender as ThttpCli do
|
||||
end;
|
||||
end; // progFrmHttpGetUpdate
|
||||
|
||||
procedure TmainFrm.statusBarHttpGetUpdate(sender:Tobject; buffer:pointer; len:integer);
|
||||
begin
|
||||
with sender as ThttpCli do
|
||||
setStatusBarText( 'Downloading '+intToStr(safeDiv(RcvdCount*100, contentLength))+'%' );
|
||||
end; // statusBarHttpGetUpdate
|
||||
|
||||
function purgeFilesCB(f:Tfile; childrenDone:boolean; par, par2:integer):TfileCallbackReturn;
|
||||
begin
|
||||
result:=[];
|
||||
|
||||
109
utillib.pas
109
utillib.pas
@ -44,6 +44,7 @@ type
|
||||
TnameExistsFun = function(user:string):boolean;
|
||||
|
||||
procedure doNothing(); inline; // useful for readability
|
||||
function httpsCanWork():boolean;
|
||||
function accountExists(user:string; evenGroups:boolean=FALSE):boolean;
|
||||
function getAccount(user:string; evenGroups:boolean=FALSE):Paccount;
|
||||
function nodeToFile(n:TtreeNode):Tfile;
|
||||
@ -1651,71 +1652,101 @@ result:=inputQueryLongdlg.ShowModal() = mrOk;
|
||||
if result then value:=inputQueryLongdlg.inputBox.Text;
|
||||
end; // inputQueryLong
|
||||
|
||||
function dllIsPresent(name:string):boolean;
|
||||
var h: HMODULE;
|
||||
begin
|
||||
h:=LoadLibrary(@name);
|
||||
result:= h<>0;
|
||||
FreeLibrary(h);
|
||||
end;
|
||||
|
||||
function httpsCanWork():boolean;
|
||||
const
|
||||
files: array of string = ['libcrypto-1_1.dll','libssl-1_1.dll'];
|
||||
baseUrl = 'http://rejetto.com/hfs/';
|
||||
// these should be made resourcestring but then a runtime error is raised
|
||||
MSG = 'An HTTPS action is required but some files are missing. Download them?';
|
||||
MSG_OK = 'Download completed';
|
||||
MSG_KO = 'Download failed';
|
||||
var
|
||||
s: string;
|
||||
missing: TStringDynArray;
|
||||
begin
|
||||
missing:=NIL;
|
||||
for s in files do
|
||||
if not FileExists(s) and not dllIsPresent(s) then
|
||||
addString(s, missing);
|
||||
if missing=NIL then
|
||||
exit(TRUE);
|
||||
if msgDlg(MSG, MB_OKCANCEL+MB_ICONQUESTION) <> MROK then
|
||||
exit(FALSE);
|
||||
for s in missing do
|
||||
if not httpGetFile(baseUrl+s, s, 2, mainfrm.statusBarHttpGetUpdate) then
|
||||
begin
|
||||
msgDlg(MSG_KO, MB_ICONERROR);
|
||||
exit(FALSE);
|
||||
end;
|
||||
mainfrm.setStatusBarText(MSG_OK);
|
||||
result:=TRUE;
|
||||
end; // httpsCanWork
|
||||
|
||||
function httpGet(url:string; from:int64=0; size:int64=-1):string;
|
||||
var
|
||||
http: THttpCli;
|
||||
reply: Tstringstream;
|
||||
begin
|
||||
if size = 0 then
|
||||
begin
|
||||
result:='';
|
||||
exit;
|
||||
end;
|
||||
exit('');
|
||||
reply:=TStringStream.Create('');
|
||||
with ThttpClient.createURL(url) do
|
||||
try
|
||||
http:=Thttpcli.create(NIL);
|
||||
try
|
||||
http.URL:=url;
|
||||
http.followRelocation:=TRUE;
|
||||
http.rcvdStream:=reply;
|
||||
http.agent:=HFS_HTTP_AGENT;
|
||||
rcvdStream:=reply;
|
||||
if (from <> 0) or (size > 0) then
|
||||
http.contentRangeBegin:=intToStr(from);
|
||||
contentRangeBegin:=intToStr(from);
|
||||
if size > 0 then
|
||||
http.contentRangeEnd:=intToStr(from+size-1);
|
||||
http.get();
|
||||
contentRangeEnd:=intToStr(from+size-1);
|
||||
get();
|
||||
result:=reply.dataString;
|
||||
finally http.free end
|
||||
finally reply.free end
|
||||
finally
|
||||
reply.free;
|
||||
Free;
|
||||
end
|
||||
end; // httpGet
|
||||
|
||||
function httpFileSize(url:string):int64;
|
||||
var
|
||||
http: THttpCli;
|
||||
begin
|
||||
http:=Thttpcli.create(NIL);
|
||||
with ThttpClient.createURL(url) do
|
||||
try
|
||||
http.URL:=url;
|
||||
http.Agent:=HFS_HTTP_AGENT;
|
||||
try
|
||||
http.head();
|
||||
result:=http.contentLength
|
||||
except result:=-1 end;
|
||||
finally http.free end
|
||||
head();
|
||||
result:=contentLength
|
||||
except result:=-1
|
||||
end;
|
||||
finally free
|
||||
end;
|
||||
end; // httpFileSize
|
||||
|
||||
function httpGetFile(url, filename:string; tryTimes:integer=1; notify:TdocDataEvent=NIL):boolean;
|
||||
var
|
||||
http: THttpCli;
|
||||
reply: Tfilestream;
|
||||
supposed: integer;
|
||||
reply: Tfilestream;
|
||||
begin
|
||||
reply:=TfileStream.Create(filename, fmCreate);
|
||||
with ThttpClient.createURL(url) do
|
||||
try
|
||||
http:=Thttpcli.create(NIL);
|
||||
try
|
||||
http.URL:=url;
|
||||
http.RcvdStream:=reply;
|
||||
http.Agent:=HFS_HTTP_AGENT;
|
||||
http.OnDocData:=notify;
|
||||
rcvdStream:=reply;
|
||||
onDocData:=notify;
|
||||
result:=TRUE;
|
||||
try http.get()
|
||||
except result:=FALSE end;
|
||||
supposed:=http.ContentLength;
|
||||
finally http.free end
|
||||
finally reply.free end;
|
||||
try get()
|
||||
except result:=FALSE
|
||||
end;
|
||||
supposed:=ContentLength;
|
||||
finally
|
||||
reply.free;
|
||||
free;
|
||||
end;
|
||||
result:= result and (sizeOfFile(filename)=supposed);
|
||||
if not result then deleteFile(filename);
|
||||
if not result then
|
||||
deleteFile(filename);
|
||||
|
||||
if not result and (tryTimes > 1) then
|
||||
result:=httpGetFile(url, filename, tryTimes-1, notify);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user