3
3
{-# LANGUAGE ViewPatterns #-}
4
4
{-# LANGUAGE RankNTypes #-}
5
5
{-# LANGUAGE ScopedTypeVariables #-}
6
+ {-# LANGUAGE QuasiQuotes #-}
7
+ {-# LANGUAGE MultiWayIf #-}
6
8
{-# OPTIONS_GHC -Wno-orphans #-}
7
9
{-# OPTIONS_HADDOCK hide #-}
8
10
-----------------------------------------------------------------------------
@@ -40,15 +42,19 @@ module Codec.Archive.Tar.Check.Internal (
40
42
import Codec.Archive.Tar.LongNames
41
43
import Codec.Archive.Tar.Types
42
44
import Control.Applicative ((<|>) )
43
- import qualified Data.ByteString.Lazy.Char8 as Char8
44
- import Data.Maybe (fromMaybe )
45
45
import Data.Typeable (Typeable )
46
46
import Control.Exception (Exception (.. ))
47
- import qualified System.FilePath as FilePath.Native
48
- ( splitDirectories , isAbsolute , isValid , (</>) , takeDirectory , hasDrive )
49
47
50
- import qualified System.FilePath.Windows as FilePath.Windows
51
- import qualified System.FilePath.Posix as FilePath.Posix
48
+ import System.OsPath (OsPath )
49
+ import System.OsPath.Posix (PosixPath )
50
+ import qualified System.OsPath as OSP
51
+ import qualified System.OsPath.Posix as PFP
52
+ import qualified System.OsPath.Windows as WFP
53
+
54
+ import System.OsString.Posix (pstr )
55
+ import System.OsString (osstr )
56
+ import qualified System.OsString.Posix as PS
57
+ import qualified System.OsString.Windows as WS
52
58
53
59
54
60
--------------------------
@@ -78,57 +84,79 @@ import qualified System.FilePath.Posix as FilePath.Posix
78
84
-- such as exhaustion of file handlers.
79
85
checkSecurity
80
86
:: Entries e
81
- -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError ) FileNameError )
87
+ -> GenEntries PosixPath PosixPath (Either (Either e DecodeLongNamesError ) FileNameError )
82
88
checkSecurity = checkEntries checkEntrySecurity . decodeLongNames
83
89
84
90
-- | Worker of 'Codec.Archive.Tar.Check.checkSecurity'.
85
91
--
86
92
-- @since 0.6.0.0
87
- checkEntrySecurity :: GenEntry FilePath FilePath -> Maybe FileNameError
93
+ checkEntrySecurity :: GenEntry PosixPath PosixPath -> Maybe FileNameError
88
94
checkEntrySecurity e =
89
95
check (entryTarPath e) <|>
90
96
case entryContent e of
91
97
HardLink link ->
92
98
check link
93
99
SymbolicLink link ->
94
- check (FilePath.Posix. takeDirectory (entryTarPath e) FilePath.Posix . </> link)
100
+ check (PFP. takeDirectory (entryTarPath e) PFP . </> link)
95
101
_ -> Nothing
96
102
where
103
+ checkPosix :: PosixPath -> Maybe FileNameError
97
104
checkPosix name
98
- | FilePath.Posix. isAbsolute name
99
- = Just $ AbsoluteFileName name
100
- | not (FilePath.Posix. isValid name)
101
- = Just $ InvalidFileName name
102
- | not (isInsideBaseDir (FilePath.Posix. splitDirectories name))
103
- = Just $ UnsafeLinkTarget name
104
- | otherwise = Nothing
105
-
106
- checkNative (fromFilePathToNative -> name)
107
- | FilePath.Native. isAbsolute name || FilePath.Native. hasDrive name
105
+ | PFP. isAbsolute name
108
106
= Just $ AbsoluteFileName name
109
- | not (FilePath.Native . isValid name)
107
+ | not (PFP . isValid name)
110
108
= Just $ InvalidFileName name
111
- | not (isInsideBaseDir (FilePath.Native . splitDirectories name))
109
+ | not (isInsideBaseDir (PFP . splitDirectories name))
112
110
= Just $ UnsafeLinkTarget name
113
111
| otherwise = Nothing
114
112
115
- check name = checkPosix name <|> checkNative (fromFilePathToNative name)
116
-
117
- isInsideBaseDir :: [FilePath ] -> Bool
113
+ checkNative :: PosixPath -> Maybe FileNameError
114
+ checkNative name'
115
+ | OSP. isAbsolute name || OSP. hasDrive name
116
+ = Just $ AbsoluteFileName name'
117
+ | not (OSP. isValid name)
118
+ = Just $ InvalidFileName name'
119
+ | not (isInsideBaseDir' (OSP. splitDirectories name))
120
+ = Just $ UnsafeLinkTarget name'
121
+ | otherwise
122
+ = Nothing
123
+ where
124
+ name = fromPosixPath name'
125
+
126
+ check name = checkPosix name <|> checkNative name
127
+
128
+ isInsideBaseDir :: [PosixPath ] -> Bool
118
129
isInsideBaseDir = go 0
119
130
where
120
- go :: Word -> [FilePath ] -> Bool
131
+ go :: Word -> [PosixPath ] -> Bool
132
+ go ! _ [] = True
133
+ go 0 (x : _)
134
+ | x == [pstr |..|] = False
135
+ go lvl (x : xs)
136
+ | x == [pstr |..|] = go (lvl - 1 ) xs
137
+ go lvl (x : xs)
138
+ | x == [pstr |.|] = go lvl xs
139
+ go lvl (_ : xs) = go (lvl + 1 ) xs
140
+
141
+ isInsideBaseDir' :: [OsPath ] -> Bool
142
+ isInsideBaseDir' = go 0
143
+ where
144
+ go :: Word -> [OsPath ] -> Bool
121
145
go ! _ [] = True
122
- go 0 (" .." : _) = False
123
- go lvl (" .." : xs) = go (lvl - 1 ) xs
124
- go lvl (" ." : xs) = go lvl xs
146
+ go 0 (x : _)
147
+ | x == [osstr |..|] = False
148
+ go lvl (x : xs)
149
+ | x == [osstr |..|] = go (lvl - 1 ) xs
150
+ go lvl (x : xs)
151
+ | x == [osstr |.|] = go lvl xs
125
152
go lvl (_ : xs) = go (lvl + 1 ) xs
126
153
127
154
-- | Errors arising from tar file names being in some way invalid or dangerous
128
155
data FileNameError
129
- = InvalidFileName FilePath
130
- | AbsoluteFileName FilePath
131
- | UnsafeLinkTarget FilePath
156
+ = InvalidFileName PosixPath
157
+ | AbsoluteFileName PosixPath
158
+ | UnsafeLinkTarget PosixPath
159
+ | FileNameDecodingFailure PosixPath
132
160
-- ^ @since 0.6.0.0
133
161
deriving (Typeable )
134
162
@@ -142,6 +170,7 @@ showFileNameError mb_plat err = case err of
142
170
InvalidFileName path -> " Invalid" ++ plat ++ " file name in tar archive: " ++ show path
143
171
AbsoluteFileName path -> " Absolute" ++ plat ++ " file name in tar archive: " ++ show path
144
172
UnsafeLinkTarget path -> " Unsafe" ++ plat ++ " link target in tar archive: " ++ show path
173
+ FileNameDecodingFailure path -> " Decoding failure of path " ++ show path
145
174
where plat = maybe " " (' ' : ) mb_plat
146
175
147
176
@@ -167,17 +196,17 @@ showFileNameError mb_plat err = case err of
167
196
-- Not only it is faster, but also alleviates issues with lazy I/O
168
197
-- such as exhaustion of file handlers.
169
198
checkTarbomb
170
- :: FilePath
199
+ :: PosixPath
171
200
-> Entries e
172
- -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError ) TarBombError )
201
+ -> GenEntries PosixPath PosixPath (Either (Either e DecodeLongNamesError ) TarBombError )
173
202
checkTarbomb expectedTopDir
174
203
= checkEntries (checkEntryTarbomb expectedTopDir)
175
204
. decodeLongNames
176
205
177
206
-- | Worker of 'checkTarbomb'.
178
207
--
179
208
-- @since 0.6.0.0
180
- checkEntryTarbomb :: FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError
209
+ checkEntryTarbomb :: PosixPath -> GenEntry PosixPath linkTarget -> Maybe TarBombError
181
210
checkEntryTarbomb expectedTopDir entry = do
182
211
case entryContent entry of
183
212
-- Global extended header aka XGLTYPE aka pax_global_header
@@ -186,18 +215,18 @@ checkEntryTarbomb expectedTopDir entry = do
186
215
-- Extended header referring to the next file in the archive aka XHDTYPE
187
216
OtherEntryType ' x' _ _ -> Nothing
188
217
_ ->
189
- case FilePath.Posix . splitDirectories (entryTarPath entry) of
218
+ case PFP . splitDirectories (entryTarPath entry) of
190
219
(topDir: _) | topDir == expectedTopDir -> Nothing
191
220
_ -> Just $ TarBombError expectedTopDir (entryTarPath entry)
192
221
193
222
-- | An error that occurs if a tar file is a \"tar bomb\" that would extract
194
223
-- files outside of the intended directory.
195
224
data TarBombError
196
225
= TarBombError
197
- FilePath -- ^ Path inside archive.
226
+ PosixPath -- ^ Path inside archive.
198
227
--
199
228
-- @since 0.6.0.0
200
- FilePath -- ^ Expected top directory.
229
+ PosixPath -- ^ Expected top directory.
201
230
deriving (Typeable )
202
231
203
232
instance Exception TarBombError
@@ -236,43 +265,44 @@ instance Show TarBombError where
236
265
-- such as exhaustion of file handlers.
237
266
checkPortability
238
267
:: Entries e
239
- -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError ) PortabilityError )
268
+ -> GenEntries PosixPath PosixPath (Either (Either e DecodeLongNamesError ) PortabilityError )
240
269
checkPortability = checkEntries checkEntryPortability . decodeLongNames
241
270
242
271
-- | Worker of 'checkPortability'.
243
272
--
244
273
-- @since 0.6.0.0
245
- checkEntryPortability :: GenEntry FilePath linkTarget -> Maybe PortabilityError
274
+ checkEntryPortability :: GenEntry PosixPath linkTarget -> Maybe PortabilityError
246
275
checkEntryPortability entry
247
276
| entryFormat entry `elem` [V7Format , GnuFormat ]
248
277
= Just $ NonPortableFormat (entryFormat entry)
249
278
250
279
| not (portableFileType (entryContent entry))
251
280
= Just NonPortableFileType
252
281
253
- | not (all portableChar posixPath)
282
+ | not (PS. all portableChar posixPath)
254
283
= Just $ NonPortableEntryNameChar posixPath
255
284
256
- | not (FilePath.Posix . isValid posixPath)
285
+ | not (PFP . isValid posixPath)
257
286
= Just $ NonPortableFileName " unix" (InvalidFileName posixPath)
258
- | not (FilePath.Windows . isValid windowsPath)
259
- = Just $ NonPortableFileName " windows" (InvalidFileName windowsPath )
287
+ | not (WFP . isValid windowsPath)
288
+ = Just $ NonPortableFileName " windows" (InvalidFileName posixPath )
260
289
261
- | FilePath.Posix . isAbsolute posixPath
290
+ | PFP . isAbsolute posixPath
262
291
= Just $ NonPortableFileName " unix" (AbsoluteFileName posixPath)
263
- | FilePath.Windows . isAbsolute windowsPath
264
- = Just $ NonPortableFileName " windows" (AbsoluteFileName windowsPath )
292
+ | WFP . isAbsolute windowsPath
293
+ = Just $ NonPortableFileName " windows" (AbsoluteFileName posixPath )
265
294
266
- | any (== " .. " ) (FilePath.Posix . splitDirectories posixPath)
295
+ | any (== [ PS. pstr |..|] ) (PFP . splitDirectories posixPath)
267
296
= Just $ NonPortableFileName " unix" (InvalidFileName posixPath)
268
- | any (== " .. " ) (FilePath.Windows . splitDirectories windowsPath)
269
- = Just $ NonPortableFileName " windows" (InvalidFileName windowsPath )
297
+ | any (== [ WS. pstr |..|] ) (WFP . splitDirectories windowsPath)
298
+ = Just $ NonPortableFileName " windows" (InvalidFileName posixPath )
270
299
271
- | otherwise = Nothing
300
+ | otherwise
301
+ = Nothing
272
302
273
303
where
274
- posixPath = entryTarPath entry
275
- windowsPath = fromFilePathToWindowsPath posixPath
304
+ posixPath = entryTarPath entry
305
+ windowsPath = toWindowsPath posixPath
276
306
277
307
portableFileType ftype = case ftype of
278
308
NormalFile {} -> True
@@ -281,14 +311,15 @@ checkEntryPortability entry
281
311
Directory -> True
282
312
_ -> False
283
313
284
- portableChar c = c <= '\ 127 '
314
+ portableChar c = PS. toChar c <= '\ 127 '
285
315
286
316
-- | Portability problems in a tar archive
287
317
data PortabilityError
288
318
= NonPortableFormat Format
289
319
| NonPortableFileType
290
- | NonPortableEntryNameChar FilePath
320
+ | NonPortableEntryNameChar PosixPath
291
321
| NonPortableFileName PortabilityPlatform FileNameError
322
+ | NonPortableDecodingFailure PosixPath
292
323
deriving (Typeable )
293
324
294
325
-- | The name of a platform that portability issues arise from
@@ -306,6 +337,8 @@ instance Show PortabilityError where
306
337
= " Non-portable character in archive entry name: " ++ show posixPath
307
338
show (NonPortableFileName platform err)
308
339
= showFileNameError (Just platform) err
340
+ show (NonPortableDecodingFailure posixPath)
341
+ = " Decoding failure of path " ++ show posixPath
309
342
310
343
--------------------------
311
344
-- Utils
0 commit comments