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