Skip to content

Commit 75f6d6a

Browse files
BodigrimBodigrim
committed
Factor out long names support into a separate module
1 parent 70a848e commit 75f6d6a

File tree

12 files changed

+229
-152
lines changed

12 files changed

+229
-152
lines changed

‎Codec/Archive/Tar.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -115,14 +115,16 @@ module Codec.Archive.Tar (
115115
-- | This module provides only very simple and limited read-only access to
116116
-- the 'Entry' type. If you need access to the details or if you need to
117117
-- construct your own entries then also import "Codec.Archive.Tar.Entry".
118+
GenEntry,
118119
Entry,
119120
entryPath,
120121
entryContent,
121122
GenEntryContent(..),
122123
EntryContent,
123124

124125
-- ** Sequences of tar entries
125-
Entries(..),
126+
GenEntries(..),
127+
Entries,
126128
mapEntries,
127129
mapEntriesNoFail,
128130
foldEntries,

‎Codec/Archive/Tar/Check/Internal.hs

Lines changed: 12 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -68,18 +68,14 @@ import qualified System.FilePath.Posix as FilePath.Posix
6868
-- an error.
6969
--
7070
checkSecurity :: CheckSecurityCallback
71-
checkSecurity mLink mPath e = do
72-
let path = fromMaybe (entryPath e) mPath
73-
check path
71+
checkSecurity e = do
72+
check (entryTarPath e)
7473
case entryContent e of
7574
HardLink link ->
76-
let linkTarget = fromMaybe link mLink
77-
in check (fromLinkTargetToPosixPath linkTarget)
75+
check link
7876
SymbolicLink link ->
79-
let linkTarget = fromMaybe link mLink
80-
in check (FilePath.Posix.takeDirectory (fromTarPathToPosixPath . entryTarPath $ e)
81-
FilePath.Posix.</> fromLinkTargetToPosixPath linkTarget)
82-
_ -> pure ()
77+
check (FilePath.Posix.takeDirectory (entryTarPath e) FilePath.Posix.</> link)
78+
_ -> pure ()
8379
where
8480
checkPosix name
8581
| FilePath.Posix.isAbsolute name
@@ -99,7 +95,7 @@ checkSecurity mLink mPath e = do
9995
= throwM $ UnsafeLinkTarget name
10096
| otherwise = pure ()
10197

102-
check name = checkPosix name >>= \_ -> checkNative name
98+
check name = checkPosix name >>= \_ -> checkNative (fromFilePathToNative name)
10399

104100
isInsideBaseDir :: [FilePath] -> Bool
105101
isInsideBaseDir = go 0
@@ -148,15 +144,14 @@ showFileNameError mb_plat err = case err of
148144
-- (or 'checkPortability').
149145
--
150146
checkTarbomb :: FilePath -> CheckSecurityCallback
151-
checkTarbomb expectedTopDir _mLink _mPath entry = do
147+
checkTarbomb expectedTopDir entry = do
152148
case entryContent entry of
153149
OtherEntryType 'g' _ _ -> pure () --PAX global header
154150
OtherEntryType 'x' _ _ -> pure () --PAX individual header
155151
_ ->
156-
case FilePath.Native.splitDirectories (entryPath entry) of
152+
case FilePath.Posix.splitDirectories (entryTarPath entry) of
157153
(topDir:_) | topDir == expectedTopDir -> pure ()
158-
_ -> throwM $ TarBombError expectedTopDir (entryPath entry)
159-
154+
_ -> throwM $ TarBombError expectedTopDir (entryTarPath entry)
160155

161156
-- | An error that occurs if a tar file is a \"tar bomb\" that would extract
162157
-- files outside of the intended directory.
@@ -198,7 +193,7 @@ instance Show TarBombError where
198193
-- directory separator conventions.
199194
--
200195
checkPortability :: CheckSecurityCallback
201-
checkPortability _mLink _mPath entry
196+
checkPortability entry
202197
| entryFormat entry `elem` [V7Format, GnuFormat]
203198
= throwM $ NonPortableFormat (entryFormat entry)
204199

@@ -226,9 +221,8 @@ checkPortability _mLink _mPath entry
226221
| otherwise = pure ()
227222

228223
where
229-
tarPath = entryTarPath entry
230-
posixPath = fromTarPathToPosixPath tarPath
231-
windowsPath = fromTarPathToWindowsPath tarPath
224+
posixPath = entryTarPath entry
225+
windowsPath = fromFilePathToWindowsPath posixPath
232226

233227
portableFileType ftype = case ftype of
234228
NormalFile {} -> True
@@ -262,5 +256,3 @@ instance Show PortabilityError where
262256
= "Non-portable character in archive entry name: " ++ show posixPath
263257
show (NonPortableFileName platform err)
264258
= showFileNameError (Just platform) err
265-
266-

‎Codec/Archive/Tar/LongNames.hs

Lines changed: 133 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,133 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
3+
module Codec.Archive.Tar.LongNames
4+
( encodeLongNames
5+
, decodeLongNames
6+
, DecodeLongNamesError
7+
) where
8+
9+
import Codec.Archive.Tar.Types
10+
import Control.Exception
11+
import qualified Data.ByteString.Char8 as B
12+
import qualified Data.ByteString.Lazy.Char8 as BL
13+
14+
data DecodeLongNamesError
15+
= TwoTypeKEntries
16+
| TwoTypeLEntries
17+
| NoLinkEntryAfterTypeKEntry
18+
deriving (Eq, Ord, Show)
19+
20+
instance Exception DecodeLongNamesError
21+
22+
encodeLongNames
23+
:: GenEntry FilePath FilePath
24+
-> [Entry]
25+
encodeLongNames e = maybe id (:) mEntry $ maybe id (:) mEntry' [e'']
26+
where
27+
(mEntry, e') = encodeLinkTarget e
28+
(mEntry', e'') = encodeTarPath e'
29+
30+
encodeTarPath
31+
:: GenEntry FilePath linkTarget
32+
-> (Maybe (GenEntry TarPath whatever), GenEntry TarPath linkTarget)
33+
-- ^ (LongLink entry, actual entry)
34+
encodeTarPath e = case toTarPath' (entryTarPath e) of
35+
FileNameEmpty -> (Nothing, e { entryTarPath = TarPath mempty mempty })
36+
FileNameOK tarPath -> (Nothing, e { entryTarPath = tarPath })
37+
FileNameTooLong tarPath -> (Just $ longLinkEntry $ entryTarPath e, e { entryTarPath = tarPath })
38+
39+
encodeLinkTarget
40+
:: GenEntry tarPath FilePath
41+
-> (Maybe (GenEntry TarPath LinkTarget), GenEntry tarPath LinkTarget)
42+
-- ^ (LongLink symlink entry, actual entry)
43+
encodeLinkTarget e = case entryContent e of
44+
NormalFile x y -> (Nothing, e { entryContent = NormalFile x y })
45+
Directory -> (Nothing, e { entryContent = Directory })
46+
SymbolicLink lnk -> let (mEntry, lnk') = encodeLinkPath lnk in
47+
(mEntry, e { entryContent = SymbolicLink lnk' })
48+
HardLink lnk -> let (mEntry, lnk') = encodeLinkPath lnk in
49+
(mEntry, e { entryContent = HardLink lnk' })
50+
CharacterDevice x y -> (Nothing, e { entryContent = CharacterDevice x y })
51+
BlockDevice x y -> (Nothing, e { entryContent = BlockDevice x y })
52+
NamedPipe -> (Nothing, e { entryContent = NamedPipe })
53+
OtherEntryType x y z -> (Nothing, e { entryContent = OtherEntryType x y z })
54+
55+
encodeLinkPath
56+
:: FilePath
57+
-> (Maybe (GenEntry TarPath LinkTarget), LinkTarget)
58+
encodeLinkPath lnk = case toTarPath' lnk of
59+
FileNameEmpty -> (Nothing, LinkTarget mempty)
60+
FileNameOK (TarPath name prefix)
61+
| B.null prefix -> (Nothing, LinkTarget name)
62+
| otherwise -> (Just $ longSymLinkEntry lnk, LinkTarget name)
63+
FileNameTooLong (TarPath name _) ->
64+
(Just $ longSymLinkEntry lnk, LinkTarget name)
65+
66+
-- | Resolved 'FilePath's are still POSIX file names, not native ones.
67+
decodeLongNames
68+
:: Entries e
69+
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
70+
decodeLongNames = go Nothing Nothing
71+
where
72+
go :: Maybe FilePath -> Maybe FilePath -> Entries e -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
73+
go _ _ (Fail err) = Fail (Left err)
74+
go _ _ Done = Done
75+
76+
go Nothing Nothing (Next e rest) = case entryContent e of
77+
OtherEntryType 'K' fn _ ->
78+
go (Just (otherEntryPayloadToFilePath fn)) Nothing rest
79+
OtherEntryType 'L' fn _ ->
80+
go Nothing (Just (otherEntryPayloadToFilePath fn)) rest
81+
_ ->
82+
Next (castEntry e) (go Nothing Nothing rest)
83+
84+
go Nothing (Just path) (Next e rest) = case entryContent e of
85+
OtherEntryType 'K' fn _ ->
86+
go (Just (otherEntryPayloadToFilePath fn)) (Just path) rest
87+
OtherEntryType 'L' _ _ ->
88+
Fail $ Right TwoTypeLEntries
89+
_ -> Next ((castEntry e) { entryTarPath = path }) (go Nothing Nothing rest)
90+
91+
go (Just link) Nothing (Next e rest) = case entryContent e of
92+
OtherEntryType 'K' _ _ ->
93+
Fail $ Right TwoTypeKEntries
94+
OtherEntryType 'L' fn _ ->
95+
go (Just link) (Just (otherEntryPayloadToFilePath fn)) rest
96+
SymbolicLink{} ->
97+
Next ((castEntry e) { entryContent = SymbolicLink link }) (go Nothing Nothing rest)
98+
HardLink{} ->
99+
Next ((castEntry e) { entryContent = HardLink link }) (go Nothing Nothing rest)
100+
_ ->
101+
Fail $ Right NoLinkEntryAfterTypeKEntry
102+
103+
go (Just link) (Just path) (Next e rest) = case entryContent e of
104+
OtherEntryType 'K' _ _ ->
105+
Fail $ Right TwoTypeKEntries
106+
OtherEntryType 'L' _ _ ->
107+
Fail $ Right TwoTypeLEntries
108+
SymbolicLink{} ->
109+
Next ((castEntry e) { entryTarPath = path, entryContent = SymbolicLink link }) (go Nothing Nothing rest)
110+
HardLink{} ->
111+
Next ((castEntry e) { entryTarPath = path, entryContent = HardLink link }) (go Nothing Nothing rest)
112+
_ ->
113+
Fail $ Right NoLinkEntryAfterTypeKEntry
114+
115+
otherEntryPayloadToFilePath :: BL.ByteString -> FilePath
116+
otherEntryPayloadToFilePath = B.unpack . B.takeWhile (/= '\0') . BL.toStrict
117+
118+
castEntry :: Entry -> GenEntry FilePath FilePath
119+
castEntry e = e
120+
{ entryTarPath = fromTarPathToPosixPath (entryTarPath e)
121+
, entryContent = castEntryContent (entryContent e)
122+
}
123+
124+
castEntryContent :: EntryContent -> GenEntryContent FilePath
125+
castEntryContent = \case
126+
NormalFile x y -> NormalFile x y
127+
Directory -> Directory
128+
SymbolicLink linkTarget -> SymbolicLink $ fromLinkTargetToPosixPath linkTarget
129+
HardLink linkTarget -> HardLink $ fromLinkTargetToPosixPath linkTarget
130+
CharacterDevice x y -> CharacterDevice x y
131+
BlockDevice x y -> BlockDevice x y
132+
NamedPipe -> NamedPipe
133+
OtherEntryType x y z -> OtherEntryType x y z

‎Codec/Archive/Tar/Pack.hs

Lines changed: 22 additions & 56 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ module Codec.Archive.Tar.Pack (
2626
getDirectoryContentsRecursive,
2727
) where
2828

29+
import Codec.Archive.Tar.LongNames
2930
import Codec.Archive.Tar.Types
3031
import Control.Monad (join, when, forM, (>=>))
3132
import qualified Data.ByteString as BSS
@@ -76,7 +77,10 @@ packWith :: CheckSecurityCallback
7677
-> FilePath -- ^ Base directory
7778
-> [FilePath] -- ^ Files and directories to pack, relative to the base dir
7879
-> IO [Entry]
79-
packWith secCB baseDir = preparePaths baseDir >=> packPaths secCB baseDir
80+
packWith secCB baseDir =
81+
preparePaths baseDir >=>
82+
packPaths secCB baseDir >=>
83+
(pure . concatMap encodeLongNames)
8084

8185
preparePaths :: FilePath -> [FilePath] -> IO [FilePath]
8286
preparePaths baseDir = fmap concat . interleave . map go
@@ -94,53 +98,16 @@ preparePaths baseDir = fmap concat . interleave . map go
9498
else return [relpath]
9599

96100
-- | Pack paths while accounting for overlong filepaths.
97-
packPaths :: CheckSecurityCallback -> FilePath -> [FilePath] -> IO [Entry]
98-
packPaths secCB baseDir paths =
99-
concat <$> interleave
100-
[ do let tarpathRes = toTarPath' relpath
101-
isSymlink <- pathIsSymbolicLink abspath
102-
case tarpathRes of
103-
FileNameEmpty -> throwIO $ userError "File name empty"
104-
FileNameOK tarpath
105-
| isSymlink -> do
106-
e <- packSymlinkEntry abspath tarpath
107-
secCB Nothing Nothing e
108-
pure [e]
109-
| isDir -> do
110-
e <- packDirectoryEntry abspath tarpath
111-
secCB Nothing Nothing e
112-
pure [e]
113-
| otherwise -> do
114-
e <- packFileEntry abspath tarpath
115-
secCB Nothing Nothing e
116-
pure [e]
117-
FileNameTooLong tarpath
118-
| isSymlink -> do
119-
linkTarget <- getSymbolicLinkTarget abspath
120-
symlinkEntry tarpath linkTarget >>= \case
121-
sym@(Entry { entryContent = SymbolicLink (LinkTarget bs) })
122-
| BSS.length bs > 100 -> do
123-
longEntry <- longSymLinkEntry linkTarget
124-
secCB (Just (LinkTarget bs)) (Just relpath) sym
125-
pure [longEntry, longLinkEntry relpath, sym]
126-
_ -> withLongLinkEntry relpath tarpath packSymlinkEntry
127-
| isDir -> withLongLinkEntry relpath tarpath packDirectoryEntry
128-
| otherwise -> withLongLinkEntry relpath tarpath packFileEntry
129-
| relpath <- paths
130-
, let isDir = FilePath.Native.hasTrailingPathSeparator abspath
131-
abspath = baseDir </> relpath ]
132-
where
133-
134-
-- prepend the long filepath entry if necessary
135-
withLongLinkEntry
136-
:: FilePath
137-
-> TarPath
138-
-> (FilePath -> TarPath -> IO Entry)
139-
-> IO [Entry]
140-
withLongLinkEntry relpath tarpath f = do
141-
mainEntry <- f (baseDir </> relpath) tarpath
142-
secCB Nothing (Just relpath) mainEntry
143-
pure [longLinkEntry relpath, mainEntry]
101+
packPaths :: CheckSecurityCallback -> FilePath -> [FilePath] -> IO [GenEntry FilePath FilePath]
102+
packPaths secCB baseDir paths = interleave $ flip map paths $ \relpath -> do
103+
let isDir = FilePath.Native.hasTrailingPathSeparator abspath
104+
abspath = baseDir </> relpath
105+
isSymlink <- pathIsSymbolicLink abspath
106+
let mkEntry = if isSymlink then packSymlinkEntry else
107+
(if isDir then packDirectoryEntry else packFileEntry)
108+
e <- mkEntry abspath relpath
109+
secCB e
110+
pure e
144111

145112
interleave :: [IO a] -> IO [a]
146113
interleave = unsafeInterleaveIO . go
@@ -160,8 +127,8 @@ interleave = unsafeInterleaveIO . go
160127
-- * The file contents is read lazily.
161128
--
162129
packFileEntry :: FilePath -- ^ Full path to find the file on the local disk
163-
-> TarPath -- ^ Path to use for the tar Entry in the archive
164-
-> IO Entry
130+
-> tarPath -- ^ Path to use for the tar Entry in the archive
131+
-> IO (GenEntry tarPath linkTarget)
165132
packFileEntry filepath tarpath = do
166133
mtime <- getModTime filepath
167134
perms <- getPermissions filepath
@@ -179,8 +146,8 @@ packFileEntry filepath tarpath = do
179146
-- Directory ownership and detailed permissions are not preserved.
180147
--
181148
packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk
182-
-> TarPath -- ^ Path to use for the tar Entry in the archive
183-
-> IO Entry
149+
-> tarPath -- ^ Path to use for the tar Entry in the archive
150+
-> IO (GenEntry tarPath linkTarget)
184151
packDirectoryEntry filepath tarpath = do
185152
mtime <- getModTime filepath
186153
return (directoryEntry tarpath) {
@@ -193,12 +160,11 @@ packDirectoryEntry filepath tarpath = do
193160
--
194161
-- @since 0.6.0.0
195162
packSymlinkEntry :: FilePath -- ^ Full path to find the file on the local disk
196-
-> TarPath -- ^ Path to use for the tar Entry in the archive
197-
-> IO Entry
163+
-> tarPath -- ^ Path to use for the tar Entry in the archive
164+
-> IO (GenEntry tarPath FilePath)
198165
packSymlinkEntry filepath tarpath = do
199166
linkTarget <- getSymbolicLinkTarget filepath
200-
symlinkEntry tarpath linkTarget
201-
167+
pure $ symlinkEntry tarpath linkTarget
202168

203169
-- | This is a utility function, much like 'listDirectory'. The
204170
-- difference is that it includes the contents of subdirectories.

0 commit comments

Comments
 (0)