Store1.pas

   1 UNIT Store1;
   2 {Take tracks of files in store}
   3 {just simple, no cleaning, etc}
   4 INTERFACE
   5 uses SysUtils;
   6
   7 type
   8 tfid=array [0..19] of byte;
   9 tStoreObjectInfo=object
  10  final:boolean;    {hash matched}
  11  rc:Word; {0=no error 1=not found, other}
  12  length:LongWord;  {the whole file}
  13  seglen:longword;  {from cur to end of segment}
  14  offset:LongWord;  {only valid when reading}
  15  name:tFID;
  16
  17  procedure Open(const fid:tfid);
  18  procedure Close;
  19  procedure ReadSeg(into:pointer; ofs:LongWord; len:word);
  20  function  SegmentLength(ofs:LongWord): LongWord;
  21  procedure GetSegAfter(ofs:LongWord; out base:LongWord; out limit:LongWord);
  22  procedure EnableWrite(const fid:tFID);
  23  procedure SetFLength(len:LongWord);
  24  procedure WriteSeg(ofs:LongWord;len:word;data:pointer);
  25  procedure VerifyAndReset;
  26  procedure GetMiss(out ofs:LongWord; out len:LongWord; var state:pointer); unimplemented;
  27  procedure GetMiss(out ofs:LongWord; out len:LongWord); deprecated;
  28  private
  29  dh:tHandle; {handle to the data file}
  30  filename:string[80];
  31  segi:pointer{to seg info obj};
  32  procedure SegSeek(ofs:longword); deprecated;
  33 end;
  34 tObjectInfo=tStoreObjectInfo;
  35
  36 operator :=(a:string) r:tFID;
  37 {Should consult Download on non-final files}
  38
  39 IMPLEMENTATION
  40 uses SHA1;
  41
  42 type
  43 tSegStatic=packed object
  44  first,after:LongWord;
  45  end;
  46 tSeg_ptr=^tSeg;
  47 tSeg=object(tSegStatic)
  48  next:tSeg_ptr;
  49  end;
  50 tSegInfo_ptr=^tSegInfo;
  51 pSegInfo=tSegInfo_ptr;
  52 tSegInfo=object
  53  cache:^tSeg;
  54  name:tFID;
  55  refc:byte;
  56  next:tSegInfo_ptr;
  57  finalized:boolean;
  58  procedure SetSeg(ofs,len:LongWord; state:boolean);
  59  function GetSegLen(ofs:LongWord):LongWord;
  60  procedure Free;
  61  end;
  62 var SegInfoChain:^tSegInfo;
  63
  64 type tFileNameVar=(fvFinal,fvPart,fvInfo);
  65 procedure mkfilen(var d:string; flag:tFileNameVar; const fid:tfid);
  66  function hc(b:byte):char;
  67   begin
  68   if b<10 then hc:=char(ord('0')+b)
  69           else hc:=char(ord('a')-10+b);
  70   end;
  71  var b,i:byte;
  72  begin
  73  d:='obj/';
  74  b:=system.length(d);
  75  SetLength(d,b+40);
  76  inc(b);
  77  for i:=0 to 19 do begin
  78   d[b+(i*2)]:=hc(fid[i] shr 4);
  79   d[b+(i*2)+1]:=hc(fid[i] and $F);
  80  end;
  81  case flag of
  82   fvPart: d:=d+'.prt';
  83   fvInfo: d:=d+'.seg';
  84   fvFinal:;
  85  end;
  86 end;
  87
  88 function GetSegInfo(const fid:tFID):tSegInfo_ptr;
  89  var fn:string;
  90  var fh:file of tSegStatic;
  91  var cp:^tSeg;
  92  label nocr;
  93  begin
  94  result:=SegInfoChain;
  95  while assigned(result) do begin
  96   if CompareWord(result^.name,fid,10)=0 then goto nocr;
  97   result:=result^.next;
  98  end;
  99  mkfilen(fn,fvInfo,fid);
 100  new(result);
 101  with result^ do begin
 102   cache:=nil;
 103   name:=fid;
 104   refc:=0;
 105   next:=nil;
 106   SegInfoChain:=result;
 107   Assign(fh,fn);
 108   {$I-}ReSet(fh);{$I+}if ioresult=0 then begin
 109    while not eof(fh) do begin
 110     new(cp);
 111     read(fh,cp^);
 112     cp^.next:=cache;
 113     cache:=cp;
 114    end;
 115    close(fh);
 116   end;
 117  end;
 118  nocr:
 119  Inc(result^.refc);
 120 end;
 121
 122 procedure tStoreObjectInfo.Open(const fid:tfid);
 123  begin
 124  mkfilen(filename,fvFinal,fid);
 125  segi:=nil;
 126  Offset:=0;
 127  name:=fid;
 128  dh:=FileOpen(filename,fmOpenRead or fmShareDenyWrite);
 129  if dh<>-1 then begin
 130   rc:=0;
 131   final:=true;
 132   length:=FileSeek(dh,0,fsFromEnd);
 133   FileSeek(dh,0,fsFromBeginning);
 134  end else begin
 135   mkfilen(filename,fvPart,fid);
 136   final:=false;
 137   dh:=FileOpen(filename,fmOpenRead or fmShareDenyWrite);
 138   if dh<>-1 then begin
 139    rc:=0;
 140    final:=false;
 141    length:=FileSeek(dh,0,fsFromEnd);
 142    FileSeek(dh,0,fsFromBeginning);
 143    segi:=GetSegInfo(fid);
 144    if tSegInfo(segi^).finalized then begin
 145     assert(length>0);
 146     final:=true;
 147    end;
 148   end else begin
 149    Writeln('Store1: open failed for file ',filename,', ioresult=',IOResult);
 150    rc:=2;
 151   end;
 152  end;
 153 end;
 154
 155 procedure tStoreObjectInfo.EnableWrite(const fid:tFID);
 156  begin
 157  writeln('Store1: enaling write');
 158  assert((dh=-1)or(not final));
 159  if dh=-1 then begin
 160   {file was close, create}
 161   dh:=FileCreate(filename);
 162   if dh=-1 then begin
 163    Writeln('Store1: create failed for file ',filename,', ioresult=',IOResult);
 164    rc:=3; exit end;
 165   {init length and segments}
 166   length:=0;
 167   segi:=GetSegInfo(fid);
 168  end;
 169  if dh<>-1 then begin
 170   {file was open, close and reopen rw}
 171   FileClose(dh);
 172   dh:=FileOpen(filename,fmOpenReadWrite or fmShareDenyWrite);
 173  end;
 174  if dh=-1 then rc:=2 else rc:=0;
 175 end;
 176 procedure tStoreObjectInfo.SetFLength(len:LongWord);
 177  begin
 178  assert(not final);
 179  //writeln('Store1: SetFLength ',len);
 180  length:=len;
 181  {todo: errors!!!}
 182  FileSeek(dh,len,fsFromBeginning);
 183  FileSeek(dh,0,fsFromBeginning);
 184 end;
 185 procedure tSegInfo.SetSeg(ofs,len:LongWord; state:boolean);
 186  var cp:^tSeg;
 187  var pcp:^pointer;
 188  var after:LongWord;
 189  var op:boolean;
 190  procedure Dump(c:char);
 191   begin
 192   cp:=cache;
 193   writeln('Store1: dumpCache ',c,' ',LongWord(@self));
 194   while assigned(cp) do begin
 195    writeln(cp^.first,'-',cp^.after);
 196    cp:=cp^.next;
 197   end;
 198  end;
 199  begin
 200  assert(state);
 201  after:=ofs+len;
 202  //Dump('a');
 203  pcp:=@cache;
 204  cp:=cache;
 205  //writeln('Store1: Add: ',ofs,'-',after);
 206  while assigned(cp) do begin
 207   op:=false;
 208   if (ofs<=cp^.first)and(after>=cp^.after) then begin
 209    {merge complete-encase}
 210    pcp^:=cp^.next;
 211    dispose(cp);
 212    cp:=pcp^;
 213    continue;
 214   end;
 215   if cp^.after=ofs then begin
 216    {merge left-matching}
 217    pcp^:=cp^.next;
 218    ofs:=cp^.first;
 219    dispose(cp);
 220    cp:=pcp^;
 221    continue;
 222   end;
 223   if cp^.first=after then begin
 224    {merge right-matching}
 225    pcp^:=cp^.next;
 226    after:=cp^.after;
 227    dispose(cp);
 228    cp:=pcp^;
 229    continue;
 230   end;
 231   if (after>cp^.first)and(ofs<=cp^.first)and(after<=cp^.after) then begin writeln('k'); after:=cp^.first; end;
 232   if (ofs<cp^.after)and(after>=cp^.after)and(ofs>=cp^.first) then begin writeln('l');  ofs:=cp^.after;end;
 233   if not op then pcp:=@cp^.next;
 234   cp:=pcp^;
 235  end;
 236  //Dump('b');
 237  {add the merged seg}
 238  if ofs<>after then begin
 239  new(cp);
 240  cp^.first:=ofs;
 241  cp^.after:=after;
 242  cp^.next:=cache;
 243  cache:=cp;
 244  end;
 245  //Dump('c');
 246 end;
 247 procedure tStoreObjectInfo.WriteSeg(ofs:LongWord;len:word;data:pointer);
 248  begin
 249  {todo: errors!!!}
 250  FileSeek(dh,ofs,fsFromBeginning);
 251  FileWrite(dh,data^,len);
 252  tSegInfo(segi^).SetSeg(ofs,len,true);
 253 end;
 254 procedure tStoreObjectInfo.GetMiss(out ofs:LongWord; out len:LongWord; var state:pointer);
 255  var cp,cp1,cp2:^tSeg;
 256  begin with tSegInfo(segi^) do begin
 257  {find seg with lowest base, return 0..base-1}
 258  cp1:=nil; cp2:=nil;
 259  len:=0;
 260  ofs:=LongWord(state);
 261  cp:=cache; while assigned(cp) do begin
 262   if ((cp1=nil)or(cp^.first<cp1^.first))and(cp^.first>=ofs) then cp1:=cp;
 263  cp:=cp^.next; end;
 264  if assigned(cp1) then begin
 265   cp:=cache; while assigned(cp) do begin
 266    if ((cp2=nil)or(cp^.first<cp2^.first))and(cp^.first>cp1^.first)and(cp^.first>=ofs) then cp2:=cp;
 267   cp:=cp^.next; end;
 268   if assigned(cp2) then begin
 269    ofs:=cp1^.after;
 270    len:=cp2^.first-ofs;
 271   end else begin
 272    ofs:=cp1^.after;
 273    len:=self.length-ofs;
 274   end;
 275  end else len:=self.length-ofs;
 276  state:=pointer(ofs+len);
 277 end;end;
 278 procedure tStoreObjectInfo.GetMiss(out ofs:LongWord; out len:LongWord);
 279  var state:pointer;
 280  begin
 281  state:=nil;
 282  GetMiss(ofs,len,state);
 283 end;
 284
 285
 286 procedure tStoreObjectInfo.ReadSeg(into:pointer; ofs:LongWord; len:word);
 287  var red:LongWord;
 288  begin
 289  SegSeek(ofs);
 290  assert(seglen>=len);
 291  red:=FileRead(dh,into^,len);
 292  seglen:=seglen-red;
 293  offset:=offset+red;
 294  if red=len then rc:=0 else begin
 295   //todo
 296   writeln('Store1: read ',red,' out of ',len,' requested bytes');
 297   rc:=2;
 298  end;
 299 end;
 300 procedure tSegInfo.Free;
 301  var fh:file of tSegStatic;
 302  var cp:^tSeg;
 303  var on,nn:string;
 304  begin
 305  Dec(refc); if refc>0 then begin writeln('Not saving, ',refc); exit;end;
 306  {save segs, free segs, free}
 307  mkfilen(on,fvInfo,name);
 308  Assign(fh,on);
 309  writeln('Store1: Saving segment info');
 310  ReWrite(fh);
 311  while assigned(cache) do begin
 312   cp:=cache;
 313   if not finalized then write(fh,cp^);
 314   cache:=cp^.next;
 315   dispose(cp);
 316  end;
 317  Close(fh);
 318  if finalized then begin
 319   writeln('Store1: segi finalized, renaming datafile, erasing infofile');
 320   mkfilen(on,fvPart,name);
 321   mkfilen(nn,fvFinal,name);
 322   RenameFile(on,nn);
 323   Erase(fh);
 324  end;
 325  FreeMem(@self,sizeof(self));
 326 end;
 327 procedure tStoreObjectInfo.Close;
 328  begin
 329  if assigned(segi) then tSegInfo(segi^).Free;
 330  segi:=nil;
 331  FileClose(dh);
 332  dh:=-1;
 333 end;
 334 procedure tStoreObjectInfo.VerifyAndReset;
 335  var ctx:tSHA1Context;
 336  var digest:tSHA1Digest;
 337  var buf: array [1..2048] of byte;
 338  var red:Integer;
 339  begin
 340  SegSeek(0);
 341  if seglen<length then begin writeln('Not complete! ',length-seglen); exit;end;
 342  {if check segi... then exit};
 343  SHA1Init( ctx );
 344  while seglen>0 do begin
 345   red:=sizeof(buf);
 346   if red>seglen then red:=seglen;
 347   red:=FileRead(dh,buf,red);
 348   seglen:=seglen-red;
 349   if red<0 then exit; {todo}
 350   SHA1Update( ctx, buf, red );
 351  end;
 352  SHA1Final( ctx, digest );
 353  assert(sizeof(digest)=sizeof(tfid));
 354  if CompareWord(name,digest,10)=0 then begin
 355   writeln('Store1: hash match');
 356   {todo: mark final-verified in segi, rename on segi done}
 357   final:=true;
 358   assert(assigned(segi));
 359   with tSegInfo(segi^) do begin
 360    assert( (cache^.first=0) and (cache^.after=length) and (cache^.next=nil) );
 361    finalized:=true;
 362   end;
 363   Close;
 364   {set some invalid values to prevent doing anything}
 365   length:=0; {the object MUST be closed now} seglen:=0;
 366  end else writeln('Hash not matching ',sha1print(digest),' ',sha1print(name));
 367 end;
 368
 369 function tSegInfo.GetSegLen(ofs:LongWord):LongWord;
 370  var cp:^tSeg;
 371  begin
 372  cp:=cache;
 373  while assigned(cp) do begin
 374   if (cp^.first<=ofs)and(cp^.after>ofs) then begin
 375    GetSegLen:=cp^.after-ofs;
 376   exit end;
 377   cp:=cp^.next;
 378  end;
 379  GetSegLen:=0;
 380 end;
 381 procedure tStoreObjectInfo.GetSegAfter(ofs:LongWord; out base:LongWord; out limit:LongWord);
 382  var cp:^tSeg;
 383  begin
 384  Assert(not final);
 385  cp:=tSegInfo(segi^).cache; {FIXME}
 386  while assigned(cp) do begin
 387   if (cp^.first>ofs) then begin
 388    base:=cp^.first;
 389    limit:=cp^.after-base-1;
 390   exit end;
 391   cp:=cp^.next;
 392  end;
 393 end;
 394 procedure tStoreObjectInfo.SegSeek(ofs:longword);
 395  begin
 396  if final then begin
 397   if ofs<=length then begin
 398    seglen:=length-ofs;
 399    if FileSeek(dh,ofs,fsFromBeginning)=ofs then begin
 400     offset:=ofs;
 401     rc:=0;
 402    end else rc:=3;
 403   end else rc:=5;
 404  end else if assigned(segi) then begin
 405   seglen:=tSegInfo(segi^).GetSegLen(ofs);
 406   if seglen=0 then rc:=4 else if FileSeek(dh,ofs,fsFromBeginning)<>ofs then rc:=3 else rc:=0;
 407   offset:=ofs;
 408  end else rc:=7;
 409 end;
 410 function tStoreObjectInfo.SegmentLength(ofs:LongWord): LongWord;
 411  begin
 412  if ofs>self.length then begin result:=0;exit end;
 413  if Final then result:=self.Length-ofs else begin
 414   result:=tSegInfo(segi^).GetSegLen(ofs);
 415  end;
 416 end;
 417
 418 operator :=(a:string) r:tFID;
 419  var i:byte;
 420  function unhex(c:char):byte;
 421   begin
 422   c:=upcase(c);
 423   if (c<='F')and(c>='A') then unhex:=(ord(c)-ord('A'))+10
 424   else unhex:=ord(c)-ord('0');
 425  end;
 426  begin
 427  for i:=0 to 19 do r[i]:=(unhex(a[i*2+1])shl 4)or(unhex(a[i*2+2]));
 428 end;
 429 BEGIN
 430  SegInfoChain:=nil;
 431 END.