@@ -27,18 +27,21 @@ module Codec.Archive.Tar.Unpack (
27
27
import Codec.Archive.Tar.Types
28
28
import Codec.Archive.Tar.Check
29
29
import Codec.Archive.Tar.LongNames
30
+ import Codec.Archive.Tar.PackAscii (filePathToOsPath )
30
31
31
32
import Data.Bits
32
33
( testBit )
33
34
import Data.List (partition , nub )
34
35
import Data.Maybe ( fromMaybe )
35
36
import qualified Data.ByteString.Char8 as Char8
36
37
import qualified Data.ByteString.Lazy as BS
37
- import System.FilePath
38
- ( (</>) )
39
- import qualified System.FilePath as FilePath.Native
38
+ import Prelude hiding (writeFile )
39
+ import System.File.OsPath
40
+ import System.OsPath
41
+ ( OsPath , (</>) )
42
+ import qualified System.OsPath as FilePath.Native
40
43
( takeDirectory )
41
- import System.Directory
44
+ import System.Directory.OsPath
42
45
( createDirectoryIfMissing ,
43
46
copyFile ,
44
47
setPermissions ,
@@ -110,7 +113,7 @@ unpackAndCheck
110
113
-> Entries e
111
114
-- ^ Entries to upack
112
115
-> IO ()
113
- unpackAndCheck secCB baseDir entries = do
116
+ unpackAndCheck secCB (filePathToOsPath -> baseDir) entries = do
114
117
let resolvedEntries = decodeLongNames entries
115
118
uEntries <- unpackEntries [] resolvedEntries
116
119
let (hardlinks, symlinks) = partition (\ (_, _, x) -> x) uEntries
@@ -123,11 +126,11 @@ unpackAndCheck secCB baseDir entries = do
123
126
-- files all over the place.
124
127
125
128
unpackEntries :: Exception e
126
- => [(FilePath , FilePath , Bool )]
129
+ => [(OsPath , OsPath , Bool )]
127
130
-- ^ links (path, link, isHardLink)
128
131
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError )
129
132
-- ^ entries
130
- -> IO [(FilePath , FilePath , Bool )]
133
+ -> IO [(OsPath , OsPath , Bool )]
131
134
unpackEntries _ (Fail err) = either throwIO throwIO err
132
135
unpackEntries links Done = return links
133
136
unpackEntries links (Next entry es) = do
@@ -154,31 +157,37 @@ unpackAndCheck secCB baseDir entries = do
154
157
BlockDevice {} -> unpackEntries links es
155
158
NamedPipe -> unpackEntries links es
156
159
157
- extractFile permissions (fromFilePathToNative -> path) content mtime = do
160
+ extractFile :: Permissions -> FilePath -> BS. ByteString -> EpochTime -> IO ()
161
+ extractFile permissions (filePathToNativeOsPath -> path) content mtime = do
158
162
-- Note that tar archives do not make sure each directory is created
159
163
-- before files they contain, indeed we may have to create several
160
164
-- levels of directory.
161
165
createDirectoryIfMissing True absDir
162
- BS. writeFile absPath content
166
+ writeFile absPath content
163
167
setOwnerPermissions absPath permissions
164
168
setModTime absPath mtime
165
169
where
166
170
absDir = baseDir </> FilePath.Native. takeDirectory path
167
171
absPath = baseDir </> path
168
172
169
- extractDir (fromFilePathToNative -> path) mtime = do
173
+ extractDir :: FilePath -> EpochTime -> IO ()
174
+ extractDir (filePathToNativeOsPath -> path) mtime = do
170
175
createDirectoryIfMissing True absPath
171
176
setModTime absPath mtime
172
177
where
173
178
absPath = baseDir </> path
174
179
175
- saveLink isHardLink (fromFilePathToNative -> path) (fromFilePathToNative -> link) links
176
- = seq (length path)
177
- $ seq (length link)
178
- $ (path, link, isHardLink): links
179
-
180
+ saveLink
181
+ :: t
182
+ -> FilePath
183
+ -> FilePath
184
+ -> [(OsPath , OsPath , t )]
185
+ -> [(OsPath , OsPath , t )]
186
+ saveLink isHardLink (filePathToNativeOsPath -> path) (filePathToNativeOsPath -> link) =
187
+ path `seq` link `seq` ((path, link, isHardLink) : )
180
188
181
189
-- for hardlinks, we just copy
190
+ handleHardLinks :: [(OsPath , OsPath , t )] -> IO ()
182
191
handleHardLinks = mapM_ $ \ (relPath, relLinkTarget, _) ->
183
192
let absPath = baseDir </> relPath
184
193
-- hard links link targets are always "absolute" paths in
@@ -197,6 +206,7 @@ unpackAndCheck secCB baseDir entries = do
197
206
-- This error handling isn't too fine grained and maybe should be
198
207
-- platform specific, but this way it might catch erros on unix even on
199
208
-- FAT32 fuse mounted volumes.
209
+ handleSymlinks :: [(OsPath , OsPath , c )] -> IO ()
200
210
handleSymlinks = mapM_ $ \ (relPath, relLinkTarget, _) ->
201
211
let absPath = baseDir </> relPath
202
212
-- hard links link targets are always "absolute" paths in
@@ -220,19 +230,22 @@ unpackAndCheck secCB baseDir entries = do
220
230
else throwIO e
221
231
)
222
232
233
+ filePathToNativeOsPath :: FilePath -> OsPath
234
+ filePathToNativeOsPath = filePathToOsPath . fromFilePathToNative
235
+
223
236
-- | Recursively copy the contents of one directory to another path.
224
237
--
225
238
-- This is a rip-off of Cabal library.
226
- copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
239
+ copyDirectoryRecursive :: OsPath -> OsPath -> IO ()
227
240
copyDirectoryRecursive srcDir destDir = do
228
241
srcFiles <- getDirectoryContentsRecursive srcDir
229
242
copyFilesWith copyFile destDir [ (srcDir, f)
230
243
| f <- srcFiles ]
231
244
where
232
245
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
233
246
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
234
- copyFilesWith :: (FilePath -> FilePath -> IO () )
235
- -> FilePath -> [(FilePath , FilePath )] -> IO ()
247
+ copyFilesWith :: (OsPath -> OsPath -> IO () )
248
+ -> OsPath -> [(OsPath , OsPath )] -> IO ()
236
249
copyFilesWith doCopy targetDir srcFiles = do
237
250
238
251
-- Create parent directories for everything
@@ -251,10 +264,10 @@ copyDirectoryRecursive srcDir destDir = do
251
264
-- parent directories. The list is generated lazily so is not well defined if
252
265
-- the source directory structure changes before the list is used.
253
266
--
254
- getDirectoryContentsRecursive :: FilePath -> IO [FilePath ]
255
- getDirectoryContentsRecursive topdir = recurseDirectories [" " ]
267
+ getDirectoryContentsRecursive :: OsPath -> IO [OsPath ]
268
+ getDirectoryContentsRecursive topdir = recurseDirectories [mempty ]
256
269
where
257
- recurseDirectories :: [FilePath ] -> IO [FilePath ]
270
+ recurseDirectories :: [OsPath ] -> IO [OsPath ]
258
271
recurseDirectories [] = return []
259
272
recurseDirectories (dir: dirs) = unsafeInterleaveIO $ do
260
273
(files, dirs') <- collect [] [] =<< listDirectory (topdir </> dir)
@@ -271,7 +284,7 @@ copyDirectoryRecursive srcDir destDir = do
271
284
then collect files (dirEntry: dirs') entries
272
285
else collect (dirEntry: files) dirs' entries
273
286
274
- setModTime :: FilePath -> EpochTime -> IO ()
287
+ setModTime :: OsPath -> EpochTime -> IO ()
275
288
setModTime path t =
276
289
setModificationTime path (posixSecondsToUTCTime (fromIntegral t))
277
290
`Exception.catch` \ e -> case ioeGetErrorType e of
@@ -281,7 +294,7 @@ setModTime path t =
281
294
InvalidArgument -> return ()
282
295
_ -> throwIO e
283
296
284
- setOwnerPermissions :: FilePath -> Permissions -> IO ()
297
+ setOwnerPermissions :: OsPath -> Permissions -> IO ()
285
298
setOwnerPermissions path permissions =
286
299
setPermissions path ownerPermissions
287
300
where
@@ -291,5 +304,5 @@ setOwnerPermissions path permissions =
291
304
setOwnerReadable (testBit permissions 8 ) $
292
305
setOwnerWritable (testBit permissions 7 ) $
293
306
setOwnerExecutable (testBit permissions 6 ) $
294
- setOwnerSearchable (testBit permissions 6 ) $
307
+ setOwnerSearchable (testBit permissions 6 )
295
308
emptyPermissions
0 commit comments