lazarus、delphi文件Http下载断点续传的实现

下载大文件时，断点续传是很有必要的，特别是网速度慢且不稳定的情况下，很难保证不出意外，一旦意外中断，又要从头下载，会很让人抓狂。断点续传就能很好解决意外中断情况，再次下载时不需要从头下载，从上次中断处继续下载即可，这样下载几G或十几G大小的一个文件都没问题。本文介绍利用miniframe开源Web框架分别在lazarus、delphi下实现文件HTTP下载断点续传的功能。

本文Demo还实现了批量下载文件，同步服务器上的文件到客户端的功能。文件断点续传原理：分块下载，下载后客户端逐一合并，同时保存已下载的位置，当意外中断再次下载时从保存的位置开始下载即可。这其中还要保证，中断后再次下载时服务器上相应的文件如果更新了，还得重新下载，不然下载到的文件是错了。说明：以下代码lazarus或delphi环境下都能使用。全部源码及Demo请到miniframe开源web框架下载: https://www.wyeditor.com/miniframe/或https://github.com/dajingshan/miniframe。

服务器端代码

文件下载断点续传服务器端很简单，只要提供客户端要求下载的开始位置和指定大小的块即可。

以下是服务器获取文件信息和下载一个文件一块的代码：

<%@//Script头、过程和函数定义
program codes;
%>
<%!//声明变量
var
i,lp: integer;
FileName, RelativePath, FromPath, ErrStr: string;
json: TminiJson;
FS: TFileStream;
function GetOneDirFileInfo(Json: TminiJson; Path: string): string;
var
Status: Integer;
SearchRec: TSearchRec;
json_sub: TminiJson;
begin
Path := PathWithSlash(Path);
SearchRec := TSearchRec.Create;
Status := FindFirst(Path + '*.*', faAnyFile, SearchRec);
try
while Status = 0 do
begin
if SearchRec.Attr and faDirectory = faDirectory then
begin
if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
GetOneDirFileInfo(Json, Path + SearchRec.Name + '\');
end else
begin
FileName := Path + SearchRec.Name;
try
if FileExists(FileName) then
begin
json_sub := Pub.GetJson;
json_sub.SO; //初始化或 json.Init;
json_sub.S['filename'] := SearchRec.name;
json_sub.S['RelativePath'] := GetDeliBack(FileName, FromPath);
json_sub.S['FileTime'] := FileGetFileTimeA(FileName);
json_sub.I['size'] := SearchRec.Size;
json.A['list'] := json_sub;
end;
except
//print(ExceptionParam)
end;//}
end;
Status := FindNext(SearchRec);
end;
finally
FindClose(SearchRec);
SearchRec.Free;
end;//*)
end;
%>
<%
begin
FromPath := 'D:\code\delphi\sign\发行文件'; //下载源目录
json := Pub.GetJson; //这样创建json对象不需要自己释放，系统自动管理
json.SO; //初始化或 json.Init;
// 验证是否登录代码
{if not Request.IsLogin('Logined') then
begin
json.S['retcode'] := '300';
json.S['retmsg'] := '你还没有登录(no logined)！';
print(json.AsJson(true));
exit;
end;//}
json.S['retcode'] := '200';
json.S['retmsg'] := '成功！';
if Request.V('opr') = '1' then
begin //获取服务上指定目录的文件信息
GetOneDirFileInfo(Json, FromPath);
end else
if Request.V('opr') = '2' then
begin //下载指定文件给定大小的块
FromPath := PathWithSlash(FromPath);
RelativePath := Request.V('fn');
FileName := FromPath + RelativePath;
Fs := Pub.GetFS(FileName, fmShareDenyWrite, ErrStr);
if trim(ErrStr) <> '' then
begin
json.S['retcode'] := '300';
json.S['retmsg'] := ErrStr;
print(json.AsJson(true));
exit;
end;
Fs.Position := StrToInt(Request.V('pos'));
Response.ContentStream := TMemoryStream.Create; //注意不能用 Pub.GetMs，这是因为Pub.GetMs创建的对象在动态脚本运行完就释放了
Response.ContentStream.CopyFrom(Fs, StrToInt(Request.V('size')));
//返回流数据
Response.ContentType := 'application/octet-stream';
end;
print(json.AsJson(true));
end;
%>

客户端代码

客户端收到块后，进行合并。全部块下载完成后，还要把新下载的文件的文件修改为与服务器上的文件相同。以下是客户端实现的主代码：

procedure TMainForm.UpgradeBlock_Run(var ThreadRetInfo: TThreadRetInfo);
const
BlockSize = 1024*1024; //1M
var
HTML, ToPath, RelativePath, FN, Tmp, TmpFileName, FailFiles, SuccFiles, Newfn, TmpToPath: string;
Json, TmpJson: TminiJson;
lp, I, Number, HadUpSize, AllSize, AllBlockCount, MySize, MyNumber: Int64;
Flag: boolean;
SL, SLDate, SLSize, SLTmp: TStringlist;
MS: TMemoryStream;
Fs: TFileStream;
procedure HintMsg(Msg: string);
begin
FMyMsg := Msg; // '正在获取文件列表。。。';
ThreadRetInfo.Self.Synchronize(ThreadRetInfo.Self, MyUpdateface); //为什么不直接用匿名，因为laz不支持
end;
begin
ToPath := 'D:\superhtml'; //如果是当前程序更新 ExtractFilePath(ParamStr(0))
ThreadRetInfo.Ok := false;
HintMsg('正在获取文件列表。。。');
if not HttpPost('/接口/同步文件到客户端.html?opr=1',
'', ThreadRetInfo.ErrStr, ThreadRetInfo.HTML) then exit;
if Pos('{', ThreadRetInfo.HTML) <> 1 then
begin
ThreadRetInfo.ErrStr :='请先检查脚本源码是否配置正确！';
exit;
end;
ToPath := Pub.PathWithSlash(ToPath);
Json := TminiJson.Create;
SL := TStringlist.Create;
SLDate := TStringlist.Create;
SLSize := TStringlist.Create;
SLTmp := TStringlist.Create;
try
Json.LoadFromString(ThreadRetInfo.HTML);
if json.S['retcode'] = '200' then
begin
TmpJson := json.A['list'];
for lp := 0 to TmpJson.length - 1 do
begin
HintMsg(lp.ToString + '/' + TmpJson.length.ToString + '正在检查文件:' + RelativePath);
RelativePath := TmpJson[lp].S['RelativePath'];
if trim(RelativePath) = '' then Continue;
Flag := FileExists(ToPath + RelativePath);
if Flag then
begin
if (PubFile.FileGetFileTimeA(ToPath + RelativePath) = TmpJson[lp].S['FileTime']) and
(PubFile.FileGetFileSize(ToPath + RelativePath) = TmpJson[lp].I['Size']) then
else
Flag := false;
end;
if not Flag then //此文件需要更新
begin
SL.Add(RelativePath);
SLDate.Add(TmpJson[lp].S['FileTime']);
SLSize.Add(TmpJson[lp].S['Size']);
end;
end;
//开始下载
FailFiles := '';
SuccFiles := '';
HintMsg('需要更新的文件共有' + IntToStr(SL.Count) + '个。。。');
for lp := 0 to SL.Count - 1 do
begin
RelativePath := SL[lp];
if RelativePath[1] = '\' then RelativePath := Copy(RelativePath, 2, MaxInt);
FN := ToPath + RelativePath;
//先计算要分几个包，以处理进度
Number := 0;
HadUpSize := 0;
AllSize := StrToInt64(SLSize[lp]);
AllBlockCount := 0;
while true do
begin
AllBlockCount := AllBlockCount + 1;
if AllSize - HadUpSize >= BlockSize then
MySize := BlockSize
else
MySize := AllSize - HadUpSize;
HadUpSize := HadUpSize + MySize;
if HadUpSize >= AllSize then
break;
end;
//开始分块下载
Number := 0;
HadUpSize := 0;
//AllSize := Fs.Size;
//TmpToPath := PubFile.FileGetTemporaryPath;
Newfn := '@_' + PubPWD.GetMd5(SLDate[lp] + SLSize[lp]) + ExtractFileName(FN); //Pub.GetClientUniqueCode;
if FileExists(ToPath + Newfn) and (FileExists(FN)) then
begin
SLTmp.LoadFromFile(ToPath + Newfn);
MyNumber := StrToInt64(trim(SLTmp.Text));
Fs := TFileStream.Create(FN, fmOpenWrite);
end else
begin
MyNumber := 0;
Fs := TFileStream.Create(FN, fmCreate);
end;
try
while true do
begin
HintMsg('正在下载文件[' + Pub.GetDeliBack(RelativePath, '@@') + ']第[' + IntToStr(Number + 1) + '/' + IntToStr(AllBlockCount) + ']个包。。。');
if AllSize - HadUpSize >= BlockSize then
MySize := BlockSize
else
MySize := AllSize - HadUpSize;
Number := Number + 1;
if (MyNumber = 0) or (Number >= MyNumber) or (HadUpSize + MySize >= AllSize) then
begin
for I := 1 to 2 do //意外出错重试一次
begin
if not HttpPost('/接口/同步文件到客户端.html?opr=2fn=' + UrlEncode(RelativePath) +
'pos=' + UrlEncode(IntToStr(HadUpSize)) + 'size=' + UrlEncode(IntToStr(MySize)),
'', ThreadRetInfo.ErrStr, ThreadRetInfo.HTML, MS) then
begin
if I = 2 then
begin
ThreadRetInfo.ErrStr := Json.S['retmsg'];
exit;
end else
Continue;
end;
if Pos('{', ThreadRetInfo.HTML) < 1 then
begin
if I = 2 then
begin
ThreadRetInfo.ErrStr := Json.S['retmsg'];
exit;
end else
Continue;
end;
Json.LoadFromString(ThreadRetInfo.HTML);
if json.S['retcode'] <> '200' then
begin
if I = 2 then
begin
ThreadRetInfo.ErrStr := Json.S['retmsg'];
exit;
end else
Continue;
end;
break;
end;
if MS = nil then
begin
ThreadRetInfo.ErrStr := '没能下载到文件[' + RelativePath + ']！' + json.S['retmsg'];
exit;
end else
begin
Fs.Position := HadUpSize;
MS.Position := 0;
Fs.CopyFrom(MS, MS.Size);
MS.Free;
MS := nil;
SLTmp.Text := Number.ToString;
try
SLTmp.SaveToFile(ToPath + Newfn);
except
end;
end;
end;
HadUpSize := HadUpSize + MySize;
if HadUpSize >= AllSize then
begin //全部下载完成
Fs.Free;
Fs := nil;
Sleep(10);
PubFile.FileChangeFileDate(Fn, SLDate[lp]);
DeleteFile(ToPath + Newfn);
SuccFiles := SuccFiles + #13#10 + RelativePath;
break;
end;
end;
finally
if Fs <> nil then
Fs.Free;
end;
end;
ThreadRetInfo.HTML := '';
if trim(SuccFiles) <> '' then
ThreadRetInfo.HTML := '本次更新了以下文件：'#13#10 + SuccFiles;
//if trim(FailFiles) <> '' then
//ThreadRetInfo.HTML := trim(ThreadRetInfo.HTML + #13#10'以下文件更新失败：'#13#10 + FailFiles);
end;
finally
SLTmp.Free;
SLSize.Free;
SL.Free;
Json.Free;
SLDate.Free;
end;
ThreadRetInfo.Ok := true;
end;

以下是Demo运行界面：

金蜘蛛网页设计器