-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathArhiveDirectory.hs
executable file
·366 lines (313 loc) · 20 KB
/
ArhiveDirectory.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
{-# OPTIONS_GHC -cpp #-}
----------------------------------------------------------------------------------------------------
---- Ðàáîòà ñ îãëàâëåíèåì àðõèâà. ------
---- Ýòîò ìîäóëü ñîäåðæèò ïðîöåäóðû äëÿ: ------
---- * ÷òåíèÿ ñòðóêòóðû âõîäíîãî àðõèâà (ò.å. êàòàëîãîâ è äðóãèõ ñëóæåáíûõ áëîêîâ) ------
---- * çàïèñè è ÷òåíèÿ êàòàëîãîâ àðõèâà ------
----------------------------------------------------------------------------------------------------
module ArhiveDirectory where
import Prelude hiding (catch)
import Control.Concurrent
import Control.Monad
import Control.OldException
import Data.HashTable as Hash
import Data.Int
import Data.List
import Data.Maybe
import Data.Word
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import System.Mem
import GHC.PArr
import TABI
import Utils
import Errors
import Files
import qualified ByteStream
import FileInfo
import CompressionLib
import Compression (CRC, isFakeCompressor)
import UI
import Options
import ArhiveStructure
import Arhive7zLib
{-# NOINLINE archiveReadInfo #-}
-- |Ïðî÷èòàòü êàòàëîã àðõèâà FreeArc/7z.dll
archiveReadInfo command -- âûïîëíÿåìàÿ êîìàíäà ñî âñåìè å¸ îïöèÿìè
arc_basedir -- áàçîâûé êàòàëîã âíóòðè àðõèâà ("" äëÿ êîìàíä äîáàâëåíèÿ)
disk_basedir -- áàçîâûé êàòàëîã íà äèñêå ("" äëÿ êîìàíä äîáàâëåíèÿ/ëèñòèíãà)
filter_f -- ïðåäèêàò äëÿ ôèëüòðàöèè ñïèñêà ôàéëîâ â àðõèâå
processFooterInfo -- ïðîöåäóðà, âûïîëíÿåìàÿ íà äàííûõ èç FOOTER_BLOCK
arcname = do -- èìÿ ôàéëà, ñîäåðæàùåãî àðõèâ
(archive,footer) <- arcOpen command arcname
case archive of
Left sz -> szReadInfo sz footer filter_f processFooterInfo arcname
Right my -> myArchiveReadInfo my footer command arc_basedir disk_basedir filter_f processFooterInfo
{-# NOINLINE arcOpen #-}
-- |Îòêðûòü àðõèâ FreeArc/7z.dll
arcOpen command arcname = do
savedErr <- ref Nothing
savedErrcodeHandler <- val errcodeHandler
errcodeHandler =: (\err -> do savedErr =: Just err; fail "")
szArc <- try$ szOpenArchive (Left command) arcname -- ïîïðîáóåì îòêðûòü àðõèâ ÷åðåç 7z.dll
myArc <- try$ myOpenArchive command arcname -- ... à òåïåðü êàê àðõèâ FreeArc
errcodeHandler =: savedErrcodeHandler
err <- val savedErr
case (szArc,myArc,err) of -- à òåïåðü âûáåðåì èç íèõ òîò, ÷òî íà÷èíàåòñÿ ðàíüøå (ïîñêîëüêó âíóòðè îäíîãî àðõèâà ìîæåò áûòü äðóãîé è ïðèòîì áåç ñæàòèÿ)
(Left _, Left _, Just err) -> registerError err
(Left _, Left my, _) -> throwIO my
(Right (sz,szFooter), Left _, _) -> return (Left sz, szFooter)
(Left _, Right (my,myFooter), _) -> return (Right my, myFooter)
(Right (sz,szFooter), Right (my,myFooter), _) -> if ftSFXSize szFooter < ftSFXSize myFooter && False -- fix01: íà äàííûé ìîìåíò FreeArc ðàñïîçíà¸ò ñâîè àðõèâû òîëüêî åñëè ñèãíàòóðà àðõèâà íàõîäèòñÿ â ñàìîì êîíöå ôàéëà
then do archiveClose my; return (Left sz, szFooter)
else do szArcClose sz; return (Right my, myFooter)
-- |Çàêðûòèå àðõèâà FreeArc/7z.dll
arcOpenClose (Left sz) = szArcClose sz
arcOpenClose (Right my) = archiveClose my
----------------------------------------------------------------------------------------------------
---- Îòêðûòèå àðõèâà FreeArc -----------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
{-# NOINLINE myOpenArchive #-}
-- |Îòêðûòü àðõèâ FreeArc
myOpenArchive command arcname = do
if opt_broken_archive command /= "-"
then findBlocksInBrokenArchive arcname
else archiveReadFooter command arcname
{-# NOINLINE myArchiveReadInfo #-}
-- |Ïðî÷èòàòü êàòàëîã àðõèâà FreeArc
myArchiveReadInfo archive footer command arc_basedir disk_basedir filter_f processFooterInfo = do
-- Âûïîëíèì íà FOOTER_BLOCK ïåðåäàííóþ ïðîöåäóðó
processFooterInfo (Just archive) footer
-- Ïðî÷èòàåì ñîäåðæèìîå áëîêîâ êàòàëîãà, îïèñàííûõ â FOOTER_BLOCK
let dir_blocks = filter ((DIR_BLOCK==).blType) (ftBlocks footer)
files <- foreach dir_blocks $ \block -> do
withPool $ \pool -> do
(buf,size) <- archiveBlockReadAll pool (opt_decryption_info command) block
archiveReadDir arc_basedir disk_basedir (opt_dir_exclude_path command) archive (blPos block) filter_f (return (buf,size))
let data_blocks = concatMap fst files
directory = concatMap snd files
-- Äîáàâèì â arcinfo èíôîðìàöèþ î ñïèñêå ôàéëîâ â àðõèâå
return ArchiveInfo { arcArchive = Just archive
, arcFooter = footer
, arcDirectory = directory
, arcDataBlocks = data_blocks
, arcDirBytes = sum (map blOrigSize dir_blocks)
, arcDirCBytes = sum (map blCompSize dir_blocks)
, arcDataBytes = sum (map blOrigSize data_blocks)
, arcDataCBytes = sum (map blCompSize data_blocks)
, arcSzArchive = Nothing
, arcArchiveType = aFreeArc
}
----------------------------------------------------------------------------------------------------
---- Çàïèñü áëîêà êàòàëîãà -------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
{-# NOINLINE archiveWriteDir #-}
-- |Çàêîäèðîâàòü `dirdata` è ïîñëàòü ïîëó÷åííûå äàííûå íà äàëüíåéøóþ îáðàáîòêó ñ ïîìîùüþ `sendBuf`
archiveWriteDir dirdata -- ñïèñîê ïàð (block :: ArchiveBlock, directory :: [FileWithCRC])
arcpos -- ïîçèöèÿ â àðõèâå, ãäå íà÷èíàåòñÿ ýòîò êàòàëîã
(receiveBuf -- "(buf,size) <- receiveBuf" ïîëó÷àåò äëÿ ðàáîòû î÷åðåäíîé áóôåð ðàçìåðîì `size`
,sendBuf) -- "sendBuf buf size len" ïîñûëàåò ñôîðìèðîâàííûå â áóôåðå äàííûå íà âûõîä
nodates -- íå çàïèñûâàòü â àðõèâ äàòû ìîäèôèêàöèè ôàéëîâ?
= do
#ifndef FREEARC_DLL
debugLog "\n Writing directory"
let blocks = map fst dirdata :: [ArchiveBlock] -- ñïèñîê ñîëèä-áëîêîâ, ïîïàâøèõ â äàííûé êàòàëîã
crcfilelist = concatMap snd dirdata :: [FileWithCRC] -- îáúåäèí¸ííûé ñïèñîê ôàéëîâ - â òîì ïîðÿäêå, â êàêîì îíè ðàñïîëîæåíû â áëîêàõ!
filelist = map fwFileInfo crcfilelist :: [FileInfo] -- èíôîðìàöèÿ î ñàìèõ ôàéëàõ
-- 0. Cîçäàäèì âûõîäíîé áóôåð, èñïîëüçóþùèé äëÿ îáùåíèÿ ñ âíåøíèì ìèðîì ôóíêöèè `receiveBuf` è `sendBuf`
stream <- ByteStream.create receiveBuf sendBuf (return ())
let write :: (ByteStream.BufferData a) => a -> IO () -- shortcuts äëÿ ôóíêöèé çàïèñè â áóôåð
write = ByteStream.write stream
writeLength = ByteStream.writeInteger stream . length
writeList :: (ByteStream.BufferData a) => [a] -> IO ()
writeList = ByteStream.writeList stream
writeIntegers = mapM_ (ByteStream.writeInteger stream)
writeTagged tag x = write tag >> write x -- çàïèñü ñ òåãàìè - äëÿ îïöèîíàëüíûõ ïîëåé
writeTaggedList tag xs = write tag >> writeList xs
-- 1. Çàêîäèðóåì îïèñàíèÿ áëîêîâ àðõèâà è êîë-âî ôàéëîâ â êàæäîì èç íèõ
writeLength dirdata -- êîë-âî áëîêîâ. Äëÿ êàæäîãî áëîêà çàïèñûâàåòñÿ:
mapM_ (writeLength.snd) dirdata -- êîë-âî ôàéëîâ
writeList$ map (map purifyCompressionMethod . blCompressor) blocks -- ìåòîä ñæàòèÿ
writeList$ map (blEncodePosRelativeTo arcpos) blocks -- îòíîñèòåëüíàÿ ïîçèöèÿ áëîêà â ôàéëå àðõèâà
writeList$ map (blCompSize ) blocks -- ðàçìåð áëîêà â óïàêîâàííîì âèäå
-- 2. Çàïèøåì â àðõèâ ñïèñîê èì¸í êàòàëîãîâ
-- Ïîëó÷èì ñïèñîê èì¸í êàòàëîãîâ è íîìåðà êàòàëîãîâ, ñîîòâåòñòâóþùèå ôàéëàì â filelist
(n, dirnames, dir_numbers) <- enumDirectories filelist
debugLog$ " Found "++show n++" directory names"
writeLength dirnames -- âðåìåííî, äëÿ îáõîäà ïðîáëåìû ñ Compressor==[String]
writeList (map unixifyPath dirnames)
-- 3. Çàêîäèðóåì îòäåëüíî êàæäîå îñòàâøååñÿ ïîëå â CompressedFile/FileInfo
-- to do: äîáàâèòü RLE-êîäèðîâàíèå ïîëåé?
let fiTimeInternal = (if nodates then const aMINIMUM_POSSIBLE_FILETIME else fiTime)
writeList$ map (fpBasename.fiStoredName) filelist -- èìåíà ôàéëîâ
writeIntegers dir_numbers -- íîìåðà êàòàëîãîâ
writeList$ map fiSize filelist -- ðàçìåðû ôàéëîâ
writeList$ map fiTimeInternal filelist -- âðåìåíà ìîäèôèêàöèè
writeList$ map fiIsDir filelist -- ïðèçíàêè êàòàëîãà
-- cfArcBlock è cfPos êîäèðóþòñÿ íåÿâíî, ïóò¸ì ñîðòèðîâêè ïî ýòèì äâóì ïîëÿì
writeList$ map fwCRC crcfilelist -- CRC
-- 4. Îïöèîíàëüíûå ïîëÿ, ïðåôèêñèðóþòñÿ ñâîèìè òåãàìè, â êîíöå - òåã îêîí÷àíèÿ îïöèîíàëüíûõ ïîëåé
write aTAG_END -- ïîêà îïöèîíàëüíûõ ïîëåé íåò, íàì îñòà¸òñÿ òîëüêî ñðàçó çàïèñàòü òåã èõ îêîí÷àíèÿ
-- 5. Âîòûñ¸! :)
ByteStream.closeOut stream
-- Ýòî ïðèâîäèò ê âûëåòó Arc.exe!!! - âñ¸ åù¸?
when (length filelist >= 10000) performGC -- Ñîáåð¸ì ìóñîð, åñëè áëîê ñîäåðæèò äîñòàòî÷íî ìíîãî ôàéëîâ
debugLog " Directory written"
#endif
return ()
-- Ñîçäàíèå ïî ñïèñêó ôàéëîâ - ñïèñêà óíèêàëüíûõ êàòàëîãîâ + íîìåð êàòàëîãà äëÿ êàæäîãî ôàéëà â ñïèñêå
enumDirectories filelist = do
-- Äëÿ êàæäîãî Stored èìåíè ôàéëà ìû èùåì èìÿ ñ òåì æå êàòàëîãîì â õåø-òàáëèöå `table`.
-- Åñëè îíî íàéäåíî, òî ìû ïîëó÷àåì èç õåø-òàáëèöû íîìåð ýòîãî êàòàëîãà,
-- à åñëè íåò - âñòàâëÿåì ýòî èìÿ â õåø-òàáëèöó ñ î÷åðåäíûì ïîðÿäêîâûì íîìåðîì, êîòîðûå
-- ãåíåðÿòñÿ ÷åðåç ïåðåìåííóþ n, è äîáàâëÿåì èìÿ êàòàëîãà â ñïèñîê `dirnames`.
-- Òàêèì îáðàçîì, õåø-òàáëèöà `table` îòîáðàæàåò èìåíà êàòàëîãîâ â èõ íîìåðà
-- â ñîçäàâàåìîì ñïèñêå âñåõ êàòàëîãîâ `dirnames`.
table <- Hash.new (==) fpHash -- îòîáðàæàåò êàòàëîãè â èõ íîìåðà
-- Âîçâðàòèòü äëÿ ñïèñêà ôàéëîâ êîëè÷åñòâî óíèêàëüíûõ èì¸í êàòàëîãîâ, èõ ïîëíûé ñïèñîê,
-- è íîìåð êàòàëîãà äëÿ êàæäîãî ôàéëà (íàïðèìåð, [0,1,0,0,2] äëÿ a\1 b\1 a\2 a\3 c\1)
let go [] dirnames dir_numbers n = return (n, reverse dirnames, reverse dir_numbers)
go (fileinfo:rest) dirnames dir_numbers n = do
let storedName = fiStoredName fileinfo -- èìÿ, ïðåäíàçíà÷åííîå äëÿ ñîõðàíåíèÿ â àðõèâå
dirname = fpParent storedName -- êàòàëîã, ê êîòîðîìó ïðèíàäëåæèò ôàéë
x <- Hash.lookup table dirname -- åñòü ëè óæå â õåøå ýòîò êàòàëîã?
case x of -- Åñëè íåò, òî
Nothing -> do Hash.insert table dirname n -- çàíåñòè â õåø íîìåð êàòàëîãà
-- Äîáàâèòü èìÿ êàòàëîãà â ñïèñîê èì¸í êàòàëîãîâ,
-- íîìåð êàòàëîãà â ñïèñîê íîìåðîâ êàòàëîãà äëÿ êàæäîãî ôàéëà,
-- è èíêðåìåíòèðîâàòü ñ÷¸ò÷èê êàòàëîãîâ
go rest (fpDirectory storedName:dirnames) (n:dir_numbers) $! n+1
Just x -> do go rest dirnames (x:dir_numbers) n
--
go filelist [] [] (0::FileCount)
----------------------------------------------------------------------------------------------------
---- ×òåíèå áëîêà êàòàëîãà -------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
{-# NOINLINE archiveReadDir #-}
-- |Ïðî÷èòàòü êàòàëîã, çàïèñàííûé ôóíêöèåé `archiveWriteDir`
archiveReadDir arc_basedir -- áàçîâûé êàòàëîã â àðõèâå
disk_basedir -- áàçîâûé êàòàëîã íà äèñêå
ep -- èñêëþ÷èòü êàòàëîãè èç èì¸í/ðàçðåøèòü àáñîëþòíûå ïóòè
archive -- ôàéë àðõèâà
arcpos -- ïîçèöèÿ â àðõèâå, ãäå íà÷èíàåòñÿ ýòîò êàòàëîã
filter_f -- ïðåäèêàò ôèëüòðàöèè ôàéëîâ
receiveBuf -- "(buf,size) <- receiveBuf" ïîëó÷àåò äëÿ ðàáîòû î÷åðåäíîé áóôåð ðàçìåðîì `size`
= do
debugLog " Decoding directory"
-- 0. Cîçäàäèì âõîäíîé áóôåð, èñïîëüçóþùèé äëÿ îáùåíèÿ ñ âíåøíèì ìèðîì ôóíêöèþ `receiveBuf`
stream <- ByteStream.open receiveBuf (\a b c->return ()) (return ())
let read :: (ByteStream.BufferData a) => IO a -- shortcuts äëÿ ôóíêöèé ÷òåíèÿ èç áóôåðà
read = ByteStream.read stream
readList :: (ByteStream.BufferData a) => Int -> IO [a]
readList = ByteStream.readList stream
readInteger = ByteStream.readInteger stream
readLength = readInteger
readIntegers n = replicateM n readInteger
-- 1. Ïðî÷èòàåì îïèñàíèÿ áëîêîâ àðõèâà
num_of_blocks <- readLength -- êîë-âî áëîêîâ
-- Äëÿ êàæäîãî áëîêà ïðî÷èòàåì:
num_of_files <- readIntegers num_of_blocks -- êîë-âî ôàéëîâ
blCompressors <- readList num_of_blocks -- ìåòîä ñæàòèÿ
blOffsets <- readList num_of_blocks -- îòíîñèòåëüíóþ ïîçèöèþ áëîêà â ôàéëå àðõèâà
blCompSizes <- readList num_of_blocks -- ðàçìåð áëîêà â óïàêîâàííîì âèäå
-- 2. Ïðî÷èòàåì èìåíà êàòàëîãîâ
total_dirs <- readLength -- Ñêîëüêî âñåãî èì¸í êàòàëîãîâ ñîõðàíåíî â ýòîì îãëàâëåíèè àðõèâà
storedName <- readList total_dirs >>== map (remove_unsafe_dirs>>>make_OS_native_path) >>== toP -- Ìàññèâ èì¸í êàòàëîãîâ
-- 3. Ïðî÷èòàåì ñïèñêè äàííûõ äëÿ êàæäîãî ïîëÿ â CompressedFile/FileInfo
let total_files = sum num_of_files -- ñóììàðíîå êîë-âî ôàéëîâ â êàòàëîãå
names <- readList total_files -- Èìåíà ôàéëîâ (áåç èìåíè êàòàëîãà)
dir_numbers <- readIntegers total_files -- Íîìåð êàòàëîãà äëÿ êàæäîãî èç ôàéëîâ
sizes <- readList total_files -- Ðàçìåðû ôàéëîâ
times <- readList total_files -- Âðåìÿ ìîäèôèêàöèè ôàéëîâ
dir_flags <- readList total_files -- Áóëåâñêèå ôëàãè "ýòî êàòàëîã?"
crcs <- readList total_files -- CRC ôàéëîâ
-- 4. Äîïîëíèòåëüíûå ïîëÿ, ïðåôèêñèðóþòñÿ ñâîèìè òåãàìè, â êîíöå - òåã îêîí÷àíèÿ äîïîëíèòåëüíûõ ïîëåé
{-repeat_while (read) (/=aTAG_END) $ \tag -> do
(isMandatory::Bool) <- read
when isMandatory $ do
registerError$ GENERAL_ERROR ("can't skip mandatory field TAG="++show tag++" in archive directory")
readInteger >>= ByteStream.skipBytes stream -- ïðîïóñòèòü äàííûå ýòîãî ïîëÿ
return ()
-}
-- 5. Âîòûñ¸! :)
ByteStream.closeIn stream
debugLog " Directory decoded"
------------------------------------------------------------------------------------------------
-- Òåïåðü ïîñòðîèì êàòàëîã ïî ïðî÷èòàííûì äàííûì -----------------------------------------------
------------------------------------------------------------------------------------------------
-- Ìàññèâû, ñîäåðæàùèå èíôîðìàöèþ î êàòàëîãàõ
let drop_arc_basedir = if arc_basedir>"" then drop (length arc_basedir + 1) else id
make_disk_name = case ep of -- Ïðåâðàùàåò èìÿ â àðõèâå â èìÿ íà äèñêå
0 -> const "" -- êîìàíäà "e" -> èñïîëüçîâàòü òîëüêî áàçîâîå èìÿ
3 -> id -- îïöèÿ -ep3 -> èñïîëüçîâàòü ïîëíîå èìÿ
_ -> stripRoot -- ïî óìîë÷àíèþ -> îáðåçàòü "d:\" ÷àñòü
-- Ìàññèâû, îòîáðàæàþùèå íîìåð êàòàëîãà â åãî Filtered/Disk name (ìàññèâ äëÿ Stored name ïîñòðîåí ñðàçó ïðè ÷òåíèè)
filteredName = fmap (drop_arc_basedir) storedName
diskName = fmap ((disk_basedir </>) . make_disk_name) filteredName
-- Ìàññèâû, îòîáðàæàþùèå íîìåð êàòàëîãà â ñòðóêòóðó PackedFilePath
storedInfo = fmap packParentDirPath storedName
filteredInfo = fmap packParentDirPath filteredName
diskInfo = fmap packParentDirPath diskName
-- Äëÿ êàæäîãî êàòàëîãà - áóëåâñêèé ôëàã: íà÷èíàåòñÿ ëè åãî èìÿ ñ áàçîâîãî êàòàëîãà ("-ap")
dirIncludedArray = fmap (arc_basedir `isParentDirOf`) storedName
dirIncluded = if arc_basedir=="" then const True else (dirIncludedArray!:)
-- Ñïèñîê ñòðóêòóð Maybe FileInfo (Nothing äëÿ òåõ ôàéëîâ, êîòîðûå íå ïðèíàäëåæàò
-- áàçîâîìó êàòàëîãó ("-ap") èëè íå ïðîõîäÿò ÷åðåç ïðåäèêàò ôèëüòðàöèè ôàéëîâ)
let make_fi dir name size time dir_flag =
if dirIncluded dir && filter_f fileinfo then Just fileinfo else Nothing
where fileinfo = FileInfo { fiFilteredName = fiFilteredName
, fiDiskName = fiDiskName
, fiStoredName = fiStoredName
, fiSize = size
, fiTime = time
, fiAttr = 0
, fiIsDir = dir_flag
, fiGroup = fiUndefinedGroup
}
fiStoredName = packFilePathPacked2 stored (fpPackedFullname stored) name
fiFilteredName = if arc_basedir>"" then packFilePathPacked2 filtered (fpPackedFullname filtered) name else fiStoredName
fiDiskName = if disk_basedir>"" || ep/=3 then packFilePathPacked2 disk (fpPackedFullname disk) name else fiFilteredName
stored = storedInfo !:dir
filtered = filteredInfo!:dir
disk = diskInfo !:dir
-- Ñîñòàâèì ñòðóêòóðû FileInfo èç îòäåëüíûõ ïîëåé, ïðî÷èòàííûõ èç àðõèâà
let fileinfos = zipWith5 make_fi dir_numbers names sizes times dir_flags
-- Ðåêîíñòðóèðóåì äåñêðèïòîðû áëîêîâ äàííûõ.
-- Ñíà÷àëà ðàçîáü¸ì ñïèñîê äëèí ôàéëîâ íà ïîäñïèñêè, îòíîñÿùèåñÿ ê îòäåëüíûì áëîêàì.
-- Ýòî ïîçâîëèò íàì âû÷èñëèòü ñóììàðíûé îáú¸ì ôàéëîâ â êàæäîì èç áëîêîâ
let filesizes = splitByLens num_of_files sizes
let blocks = map (tupleToDataBlock archive arcpos) $
zip5 blCompressors
blOffsets
(map sum filesizes)
blCompSizes
num_of_files
-- Ðàçìíîæèì ññûëêè íà äåñêðèïòîðû áëîêîâ äàííûõ, ÷òîáû õâàòèëî íà âñå ôàéëû :)
let arcblocks = concat [ replicate files_in_block blockDescriptor
| files_in_block <- num_of_files -- êîë-âî ôàéëîâ â î÷åðåäíîì áëîêå äàííûõ
| blockDescriptor <- blocks -- äåñêðèïòîð î÷åðåäíîãî áëîêà
]
-- Ïîçèöèÿ ôàéëà â áëîêå ðàâíà ñóììàðíîé äëèíå ïðåäûäóùèõ ôàéëîâ â ýòîì áëîêå.
-- filesizes - ñïèñîê ñïèñêîâ äëèí ôàéëîâ, îòíîñÿùèõñÿ ê êàæäîìó áëîêó.
-- Äëÿ òîãî, ÷òîáû ïîëó÷èòü èç íåãî ïîçèöèþ ôàéëà âíóòðè áëîêà, ìû ïðîñòî ñ÷èòàåì
-- "ñêàíèðóþùóþ ñóììó". Äîáàâëÿåì [0] â íà÷àëî êàæäîãî ñïèñêà ïîçèöèé,
-- ÷òîáû ïîëó÷èòü ïîçèöèè ÏÅÐÅÄ ôàéëàìè, à íå ïîñëå íèõ :)
-- Îäíèì ñëîâîì, åñëè num_of_files = [1..4]
-- è sizes = [1..10]
-- òî filesizes = [[1],[2,3],[4,5,6],[7,8, 9,10]]
-- è positions = [ 0, 0,2, 0,4,9, 0,7,15,24]
let positions = concatMap scanningSum filesizes
scanningSum [] = []
scanningSum xs = 0 : scanl1 (+) (init xs)
-- Òåïåðü ó íàñ ãîòîâû âñå êîìïîíåíòû äëÿ ñîçäàíèÿ ñïèñêà ôàéëîâ, ñîäåðæàùèõñÿ â ýòîì êàòàëîãå
let files = [ CompressedFile fileinfo arcblock pos crc Nothing
| (Just fileinfo, arcblock, pos, crc) <- zip4 fileinfos arcblocks positions crcs
]
return $! evalList files -- Ïåðåâåä¸ì ñîçäàííûé ñïèñîê ôàéëîâ â âû÷èñëåííîå ñîñòîÿíèå
when (total_files >= 10000) performGC -- Ñîáåð¸ì ìóñîð, åñëè áëîê ñîäåðæèò äîñòàòî÷íî ìíîãî ôàéëîâ
debugLog " Directory built"
return (blocks, files)
-- let f CompressedFile{cfFileInfo=FileInfo{fiFilteredName=PackedFilePath{fpParent=PackedFilePath{fpParent=RootDir}}}} = True
-- f _ = False