Skip to content

Commit e1e02d8

Browse files
committed
Unpack: migrate internally to OsPath
1 parent d6fb1fb commit e1e02d8

File tree

6 files changed

+92
-31
lines changed

6 files changed

+92
-31
lines changed

.github/workflows/emulated.yml

Lines changed: 46 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -29,10 +29,52 @@ jobs:
2929
githubToken: ${{ github.token }}
3030
install: |
3131
apt-get update -y
32-
apt-get install -y curl ghc libghc-tasty-quickcheck-dev libghc-file-embed-dev libghc-temporary-dev
32+
apt-get install -y autoconf build-essential curl ghc libghc-tasty-quickcheck-dev libghc-file-embed-dev libghc-temporary-dev
3333
run: |
34-
find Codec -iname '*.hs' -type f -exec sed -i.bck 's/"os-string"//g' {} \;
35-
curl -s https://hackage.haskell.org/package/os-string-2.0.3/os-string-2.0.3.tar.gz | tar xz
34+
curl -s https://hackage.haskell.org/package/os-string-2.0.6/os-string-2.0.6.tar.gz | tar xz
35+
curl -s https://hackage.haskell.org/package/filepath-1.5.3.0/filepath-1.5.3.0.tar.gz | tar xz
36+
curl -s https://hackage.haskell.org/package/file-io-0.1.4/file-io-0.1.4.tar.gz | tar xz
37+
curl -s https://hackage.haskell.org/package/unix-2.8.5.1/unix-2.8.5.1.tar.gz | tar xz
38+
curl -s https://hackage.haskell.org/package/directory-1.3.8.5/directory-1.3.8.5.tar.gz | tar xz
39+
40+
cd unix-2.8.5.1
41+
chmod +x configure
42+
./configure
43+
find /usr/lib/ghc -iname HsFFI.h
44+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/Directory.hsc
45+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/Directory/Common.hsc
46+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/Directory/PosixPath.hsc
47+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/Env/Internal.hsc
48+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/Files/Common.hsc
49+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/Files/PosixString.hsc
50+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/IO/Common.hsc
51+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/IO/PosixString.hsc
52+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/User/ByteString.hsc
53+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/User/Common.hsc
54+
55+
sed -i -e 's/MIN_VERSION_base(4, 11, 0)/1/g' System/Posix/Files.hsc
56+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/Files.hsc
57+
58+
sed -i -e 's/MIN_VERSION_filepath(1, 5, 0)/1/g' System/Posix/Env/PosixString.hsc
59+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/Env/PosixString.hsc
60+
61+
sed -i -e 's/MIN_VERSION_filepath(1, 5, 0)/1/g' System/Posix/PosixPath/FilePath.hsc
62+
sed -i -e 's/MIN_VERSION_base(4, 11, 0)/1/g' System/Posix/PosixPath/FilePath.hsc
63+
hsc2hs -Iinclude -I$(dirname $(find /usr/lib/ghc -iname HsFFI.h)) System/Posix/PosixPath/FilePath.hsc
64+
cd ..
65+
66+
cd directory-1.3.8.5
67+
chmod +x configure
68+
./configure
69+
hsc2hs -I. System/Directory/Internal/Posix.hsc
70+
cd ..
71+
72+
find . -iname '*.hs' -type f -exec sed -i.bck 's/import "filepath"/import/g' {} \;
73+
find . -iname '*.hs' -type f -exec sed -i.bck 's/import "os-string"/import/g' {} \;
74+
find . -iname '*.hs' -type f -exec sed -i.bck 's/import qualified "filepath"/import qualified/g' {} \;
75+
find . -iname '*.hs' -type f -exec sed -i.bck 's/import qualified "os-string"/import qualified/g' {} \;
76+
sed -i -e 's/MIN_VERSION_filepath(1, 5, 0)/1/g' file-io-0.1.4/posix/System/File/Platform.hs
77+
sed -i -e 's/MIN_VERSION_filepath(1, 5, 0)/1/g' file-io-0.1.4/System/File/OsPath/Internal.hs
3678
ghc --version
37-
ghc --make -itest:os-string-2.0.3 -o Main test/Properties.hs +RTS -s
79+
ghc --make -fno-safe-haskell -itest:os-string-2.0.6:filepath-1.5.3.0:file-io-0.1.4:file-io-0.1.4/posix:unix-2.8.5.1:directory-1.3.8.5 -Iunix-2.8.5.1/include:directory-1.3.8.5 -o Main test/Properties.hs +RTS -s
3880
./Main +RTS -s

.github/workflows/haskell-ci.yml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -197,7 +197,7 @@ jobs:
197197
echo " ghc-options: -Werror=missing-methods" >> cabal.project
198198
cat >> cabal.project <<EOF
199199
EOF
200-
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(bytestring|directory|htar|tar|unix)$/; }' >> cabal.project.local
200+
$HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(bytestring|directory|filepath|htar|tar|unix)$/; }' >> cabal.project.local
201201
cat cabal.project
202202
cat cabal.project.local
203203
- name: dump install plan

Codec/Archive/Tar/PackAscii.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ module Codec.Archive.Tar.PackAscii
77
, posixToByteString
88
, byteToPosixString
99
, packAscii
10+
, filePathToOsPath
1011
) where
1112

1213
import Data.ByteString (ByteString)
@@ -16,6 +17,7 @@ import Data.Char
1617
import GHC.Stack
1718
import System.IO.Unsafe (unsafePerformIO)
1819
import "os-string" System.OsString.Posix (PosixString)
20+
import qualified "filepath" System.OsPath as OS
1921
import qualified "os-string" System.OsString.Posix as PS
2022
import qualified "os-string" System.OsString.Internal.Types as PS
2123

@@ -35,3 +37,6 @@ packAscii :: HasCallStack => FilePath -> BS.Char8.ByteString
3537
packAscii xs
3638
| all isAscii xs = BS.Char8.pack xs
3739
| otherwise = error $ "packAscii: only ASCII inputs are supported, but got " ++ xs
40+
41+
filePathToOsPath :: FilePath -> OS.OsPath
42+
filePathToOsPath = unsafePerformIO . OS.encodeFS

Codec/Archive/Tar/Unpack.hs

Lines changed: 37 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -27,18 +27,21 @@ module Codec.Archive.Tar.Unpack (
2727
import Codec.Archive.Tar.Types
2828
import Codec.Archive.Tar.Check
2929
import Codec.Archive.Tar.LongNames
30+
import Codec.Archive.Tar.PackAscii (filePathToOsPath)
3031

3132
import Data.Bits
3233
( testBit )
3334
import Data.List (partition, nub)
3435
import Data.Maybe ( fromMaybe )
3536
import qualified Data.ByteString.Char8 as Char8
3637
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
4043
( takeDirectory )
41-
import System.Directory
44+
import System.Directory.OsPath
4245
( createDirectoryIfMissing,
4346
copyFile,
4447
setPermissions,
@@ -110,7 +113,7 @@ unpackAndCheck
110113
-> Entries e
111114
-- ^ Entries to upack
112115
-> IO ()
113-
unpackAndCheck secCB baseDir entries = do
116+
unpackAndCheck secCB (filePathToOsPath -> baseDir) entries = do
114117
let resolvedEntries = decodeLongNames entries
115118
uEntries <- unpackEntries [] resolvedEntries
116119
let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries
@@ -123,11 +126,11 @@ unpackAndCheck secCB baseDir entries = do
123126
-- files all over the place.
124127

125128
unpackEntries :: Exception e
126-
=> [(FilePath, FilePath, Bool)]
129+
=> [(OsPath, OsPath, Bool)]
127130
-- ^ links (path, link, isHardLink)
128131
-> GenEntries FilePath FilePath (Either e DecodeLongNamesError)
129132
-- ^ entries
130-
-> IO [(FilePath, FilePath, Bool)]
133+
-> IO [(OsPath, OsPath, Bool)]
131134
unpackEntries _ (Fail err) = either throwIO throwIO err
132135
unpackEntries links Done = return links
133136
unpackEntries links (Next entry es) = do
@@ -154,31 +157,37 @@ unpackAndCheck secCB baseDir entries = do
154157
BlockDevice{} -> unpackEntries links es
155158
NamedPipe -> unpackEntries links es
156159

157-
extractFile permissions (fromFilePathToNative -> path) content mtime = do
160+
extractFile :: Permissions -> FilePath -> BS.ByteString -> EpochTime -> IO ()
161+
extractFile permissions (filePathToNativeOsPath -> path) content mtime = do
158162
-- Note that tar archives do not make sure each directory is created
159163
-- before files they contain, indeed we may have to create several
160164
-- levels of directory.
161165
createDirectoryIfMissing True absDir
162-
BS.writeFile absPath content
166+
writeFile absPath content
163167
setOwnerPermissions absPath permissions
164168
setModTime absPath mtime
165169
where
166170
absDir = baseDir </> FilePath.Native.takeDirectory path
167171
absPath = baseDir </> path
168172

169-
extractDir (fromFilePathToNative -> path) mtime = do
173+
extractDir :: FilePath -> EpochTime -> IO ()
174+
extractDir (filePathToNativeOsPath -> path) mtime = do
170175
createDirectoryIfMissing True absPath
171176
setModTime absPath mtime
172177
where
173178
absPath = baseDir </> path
174179

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) :)
180188

181189
-- for hardlinks, we just copy
190+
handleHardLinks :: [(OsPath, OsPath, t)] -> IO ()
182191
handleHardLinks = mapM_ $ \(relPath, relLinkTarget, _) ->
183192
let absPath = baseDir </> relPath
184193
-- hard links link targets are always "absolute" paths in
@@ -197,6 +206,7 @@ unpackAndCheck secCB baseDir entries = do
197206
-- This error handling isn't too fine grained and maybe should be
198207
-- platform specific, but this way it might catch erros on unix even on
199208
-- FAT32 fuse mounted volumes.
209+
handleSymlinks :: [(OsPath, OsPath, c)] -> IO ()
200210
handleSymlinks = mapM_ $ \(relPath, relLinkTarget, _) ->
201211
let absPath = baseDir </> relPath
202212
-- hard links link targets are always "absolute" paths in
@@ -220,19 +230,22 @@ unpackAndCheck secCB baseDir entries = do
220230
else throwIO e
221231
)
222232

233+
filePathToNativeOsPath :: FilePath -> OsPath
234+
filePathToNativeOsPath = filePathToOsPath . fromFilePathToNative
235+
223236
-- | Recursively copy the contents of one directory to another path.
224237
--
225238
-- This is a rip-off of Cabal library.
226-
copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
239+
copyDirectoryRecursive :: OsPath -> OsPath -> IO ()
227240
copyDirectoryRecursive srcDir destDir = do
228241
srcFiles <- getDirectoryContentsRecursive srcDir
229242
copyFilesWith copyFile destDir [ (srcDir, f)
230243
| f <- srcFiles ]
231244
where
232245
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
233246
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
234-
copyFilesWith :: (FilePath -> FilePath -> IO ())
235-
-> FilePath -> [(FilePath, FilePath)] -> IO ()
247+
copyFilesWith :: (OsPath -> OsPath -> IO ())
248+
-> OsPath -> [(OsPath, OsPath)] -> IO ()
236249
copyFilesWith doCopy targetDir srcFiles = do
237250

238251
-- Create parent directories for everything
@@ -251,10 +264,10 @@ copyDirectoryRecursive srcDir destDir = do
251264
-- parent directories. The list is generated lazily so is not well defined if
252265
-- the source directory structure changes before the list is used.
253266
--
254-
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
255-
getDirectoryContentsRecursive topdir = recurseDirectories [""]
267+
getDirectoryContentsRecursive :: OsPath -> IO [OsPath]
268+
getDirectoryContentsRecursive topdir = recurseDirectories [mempty]
256269
where
257-
recurseDirectories :: [FilePath] -> IO [FilePath]
270+
recurseDirectories :: [OsPath] -> IO [OsPath]
258271
recurseDirectories [] = return []
259272
recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
260273
(files, dirs') <- collect [] [] =<< listDirectory (topdir </> dir)
@@ -271,7 +284,7 @@ copyDirectoryRecursive srcDir destDir = do
271284
then collect files (dirEntry:dirs') entries
272285
else collect (dirEntry:files) dirs' entries
273286

274-
setModTime :: FilePath -> EpochTime -> IO ()
287+
setModTime :: OsPath -> EpochTime -> IO ()
275288
setModTime path t =
276289
setModificationTime path (posixSecondsToUTCTime (fromIntegral t))
277290
`Exception.catch` \e -> case ioeGetErrorType e of
@@ -281,7 +294,7 @@ setModTime path t =
281294
InvalidArgument -> return ()
282295
_ -> throwIO e
283296

284-
setOwnerPermissions :: FilePath -> Permissions -> IO ()
297+
setOwnerPermissions :: OsPath -> Permissions -> IO ()
285298
setOwnerPermissions path permissions =
286299
setPermissions path ownerPermissions
287300
where
@@ -291,5 +304,5 @@ setOwnerPermissions path permissions =
291304
setOwnerReadable (testBit permissions 8) $
292305
setOwnerWritable (testBit permissions 7) $
293306
setOwnerExecutable (testBit permissions 6) $
294-
setOwnerSearchable (testBit permissions 6) $
307+
setOwnerSearchable (testBit permissions 6)
295308
emptyPermissions

cabal.haskell-ci

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,2 +1,2 @@
1-
installed: -directory -unix -bytestring
1+
installed: -directory -unix -bytestring -filepath
22
haddock: >= 8.6

tar.cabal

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,8 @@ library tar-internal
5454
containers >= 0.2 && < 0.8,
5555
deepseq >= 1.1 && < 1.6,
5656
directory >= 1.3.1 && < 1.4,
57-
filepath < 1.6,
57+
file-io < 0.2,
58+
filepath >= 1.4.100 && < 1.6,
5859
os-string >= 2.0 && < 2.1,
5960
time < 1.15,
6061
transformers < 0.7,

0 commit comments

Comments
 (0)