forked from svn2github/freearc
-
Notifications
You must be signed in to change notification settings - Fork 1
/
ArcvProcessCompress.hs
159 lines (140 loc) · 8.69 KB
/
ArcvProcessCompress.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
----------------------------------------------------------------------------------------------------
---- Ïðîöåññ óïàêîâêè äàííûõ è ñëóæåáíîé èíôîðìàöèè àðõèâà, è çàïèñè óïàêîâàííûõ äàííûõ â àðõèâ.----
---- Âûçûâàåòñÿ èç ArcCreate.hs ----
----------------------------------------------------------------------------------------------------
module ArcvProcessCompress where
import Prelude hiding (catch)
import Control.Monad
import Data.IORef
import Data.Array.IO
import Foreign.C.Types
import Foreign.Ptr
import Utils
import Files
import Errors
import Process
import FileInfo
import Compression
import Encryption
import Options (opt_data_password, opt_headers_password, opt_encryption_algorithm, limit_compression)
import UI
import ArhiveStructure
import ArhiveDirectory
import ArcvProcessExtract
import ArcvProcessRead
-- |Ïðîöåññ óïàêîâêè äàííûõ è ñëóæåáíîé èíôîðìàöèè àðõèâà, è çàïèñè óïàêîâàííûõ äàííûõ â àðõèâ.
-- Òàêæå âîçâðàùàåò ÷åðåç backdoor ñëóæåáíóþ èíôîðìàöèþ î áëîêàõ, ñîçäàííûõ ïðè çàïèñè àðõèâà
compress_AND_write_to_archive_PROCESS archive command backdoor pipe = do
-- Ïðîöåäóðà îòîáðàæåíèÿ â UI âõîäíûõ äàííûõ
let display (FileStart fi) = uiStartFile fi
display (DataChunk buf len) = uiUnpackedBytes (i len)
display (CorrectTotals files bytes) = uiCorrectTotal files bytes
display (FakeFiles cfiles) = uiFakeFiles (map cfFileInfo cfiles) 0
display _ = return ()
-- Ïðîöåäóðà çàïèñè óïàêîâàííûõ äàííûõ â àðõèâ
let write_to_archive (DataBuf buf len) = do uiCompressedBytes (i len)
archiveWriteBuf archive buf len
return len
write_to_archive NoMoreData = return 0
-- Ïðîöåäóðà êîïèðîâàíèÿ öåëèêîì ñîëèä-áëîêà èç âõîäíîãî àðõèâà â âûõîäíîé áåç ïåðåóïàêîâêè
let copy_block = do
CopySolidBlock files <- receiveP pipe
let block = (cfArcBlock (head files))
uiFakeFiles (map cfFileInfo files) (blCompSize block)
archiveCopyData (blArchive block) (blPos block) (blCompSize block) archive
DataEnd <- receiveP pipe
return ()
repeat_while (receiveP pipe) (notTheEnd) $ \msg -> case msg of
DebugLog str -> do -- Íàïå÷àòàòü îòëàäî÷íîå ñîîáùåíèå
debugLog str
DebugLog0 str -> do
debugLog0 str
CompressData block_type compressor real_compressor just_copy -> mdo
case block_type of -- Ñîîáùèì UI êàêîãî òèïà äàííûå ñåé÷àñ áóäóò ïàêîâàòüñÿ
DATA_BLOCK -> uiStartFiles (length real_compressor)
DIR_BLOCK -> uiStartDirectory
_ -> uiStartControlData
result <- ref 0 -- êîëè÷åñòâî áàéò, çàïèñàííûõ â ïîñëåäíåì âûçîâå write_to_archive
-- Ïîäñ÷¸ò CRC (òîëüêî äëÿ ñëóæåáíûõ áëîêîâ) è êîëè÷åñòâà áàéò â íåóïàêîâàííûõ äàííûõ áëîêà
crc <- ref aINIT_CRC
origsize <- ref 0
let update_crc (DataChunk buf len) = do when (block_type/=DATA_BLOCK) $ do
crc .<- updateCRC buf len
origsize += i len
update_crc _ = return ()
-- Âûÿñíèì, íóæíî ëè øèôðîâàíèå äëÿ ýòîãî áëîêà
let useEncryption = password>""
password = case block_type of
DATA_BLOCK -> opt_data_password command
DIR_BLOCK -> opt_headers_password command
FOOTER_BLOCK -> opt_headers_password command
DESCR_BLOCK -> ""
HEADER_BLOCK -> ""
RECOVERY_BLOCK -> ""
_ -> error$ "Unexpected block type "++show (fromEnum block_type)++" in compress_AND_write_to_archive_PROCESS"
algorithm = command.$ opt_encryption_algorithm
-- Åñëè äëÿ ýòîãî áëîêà íóæíî èñïîëüçîâàòü øèôðîâàíèå, òî äîáàâèòü àëãîðèòì øèôðîâàíèÿ
-- ê öåïî÷êå ìåòîäîâ ñæàòèÿ.  ðåàëüíî âûçûâàåìûé àëãîðèòì øèôðîâàíèÿ ïåðåäà¸òñÿ key è initVector,
-- à â àðõèâå çàïîìèíàþòñÿ salt è checkCode, íåîáõîäèìûé äëÿ áûñòðîé ïðîâåðêè ïàðîëÿ
(add_real_encryption, add_encryption_info) <- if useEncryption
then generateEncryption algorithm password -- not thread-safe due to use of PRNG!
else return (id,id)
-- Îêîí÷àòåëüíîå îãðàíè÷åíèå ìåòîäà ñæàòèÿ îáú¸ìîì äîñòóïíîé ïàìÿòè - íåïîñðåäñòâåííî ïåðåä ñòàðòîì àëãîðèòìà.
-- Çàïîìèíàåì â ìàññèâå îêîí÷àòåëüíî èñïîëüçîâàííûå ìåòîäû ñæàòèÿ
final_compressor <- newListArray (1,length real_compressor) real_compressor :: IO (IOArray Int String)
let limit_memory num method = do
if num > length real_compressor then return method else do -- ïðîïóñêàåì ïðîöåäóðó äëÿ àëãîðèòìîâ øèôðîâàíèÿ, êîòîðûå äîáàâëÿþòñÿ íèæå
newMethod <- method.$limit_compression command
writeArray final_compressor num newMethod
return newMethod
-- Ïðîöåññ óïàêîâêè îäíèì àëãîðèòìîì
let compressP = de_compress_PROCESS freearcCompress times command limit_memory
-- Ïîñëåäîâàòåëüíîñòü ïðîöåññîâ óïàêîâêè, ñîîòâåòñòâóþùàÿ ïîñëåäîâàòåëüíîñòè àëãîðèòìîâ `real_compressor`
let real_crypted_compressor = add_real_encryption real_compressor
processes = zipWith compressP real_crypted_compressor [1..]
compressa = case real_crypted_compressor of
[_] -> storing_PROCESS |> last processes
_ -> storing_PROCESS |> foldl1 (|>) (init processes) |> last processes
-- Ïðîöåäóðà óïàêîâêè, âûçûâàþùàÿ ïðîöåññ óïàêîâêè ñî âñåìè íåîáõîäèìûìè ïðîöåäóðàìè äëÿ ïîëó÷åíèÿ/îòïðàâêè äàííûõ
let compress_block = runFuncP compressa (do x<-receiveP pipe; display x; update_crc x; return x)
(send_backP pipe)
(write_to_archive .>>= writeIORef result)
(val result)
-- Âûáðàòü ìåæäó ïðîöåäóðîé óïàêîâêè è ïðîöåäóðîé êîïèðîâàíèÿ öåëèêîì ñîëèä-áëîêà èç âõîäíîãî àðõèâà
let compress_f = if just_copy then copy_block else compress_block
-- Óïàêîâàòü îäèí ñîëèä-áëîê
pos_begin <- archiveGetPos archive
; times <- uiStartDeCompression "compression" -- ñîçäàòü ñòðóêòóðó äëÿ ó÷¸òà âðåìåíè óïàêîâêè
; compress_f -- óïàêîâàòü äàííûå
; uiFinishDeCompression times `on` block_type==DATA_BLOCK -- ó÷åñòü â UI ÷èñòîå âðåìÿ îïåðàöèè
; uiUpdateProgressIndicator 0 -- îòìåòèòü, ÷òî ïðî÷èòàííûå äàííûå óæå îáðàáîòàíû
pos_end <- archiveGetPos archive
-- Âîçâðàòèòü â ïåðâûé ïðîöåññ èíôîðìàöèþ î òîëüêî ÷òî ñîçäàííîì áëîêå
-- âìåñòå ñî ñïèñêîì ñîäåðæàùèõñÿ â í¸ì ôàéëîâ
(Directory dir) <- receiveP pipe -- Ïîëó÷èì îò ïåðâîãî ïðîöåññà ñïèñîê ôàéëîâ â áëîêå
crc' <- val crc >>== finishCRC -- Âû÷èñëèì îêîí÷àòåëüíîå çíà÷åíèå CRC
origsize' <- val origsize
write_compressor <- if just_copy then return compressor
else getElems final_compressor >>== add_encryption_info >>== compressionDeleteTempCompressors
putP backdoor (ArchiveBlock {
blArchive = archive
, blType = block_type
, blCompressor = write_compressor
, blPos = pos_begin
, blOrigSize = origsize'
, blCompSize = pos_end-pos_begin
, blCRC = crc'
, blFiles = error "undefined ArchiveBlock::blFiles"
, blIsEncrypted = error "undefined ArchiveBlock::blIsEncrypted"
}, dir)
{-# NOINLINE storing_PROCESS #-}
-- |Âñïîìîãàòåëüíûé ïðîöåññ, ïåðåêîäèðóþùèé ïîòîê Instruction â ïîòîê CompressionData
storing_PROCESS pipe = do
let send (DataChunk buf len) = failOnTerminated >> resend_data pipe (DataBuf buf len) >> send_backP pipe (buf,len)
send DataEnd = resend_data pipe NoMoreData >> return ()
send _ = return ()
-- Ïî îêîí÷àíèè ñîîáùèì ñëåäóþùåìó ïðîöåññó, ÷òî äàííûõ áîëüøå íåò
ensureCtrlBreak "send DataEnd" (send DataEnd)$ do
-- Öèêë ïåðåêîäèðîâàíèÿ èíñòðóêöèé
repeat_while (receiveP pipe) (notDataEnd) (send)
return ()