Skip to content

Commit 7fc12d4

Browse files
bfrkbfrk
authored
Better support for symbolic links (#54)
* better support for symbolic links getSymbolicLinkStatus now gets the correct status for symbolic links. Both getFileStatus and getSymBolicLinkStatus are defined in terms of a generic getStatus. This procedure no longer calls getFilePermissions, doesFileExist, or doesDirectoryExist from System.Directory, instead we fuse their internal definitions (see System.Directory.Internal.Windows) directly into getStatus. This should make it quite a bit more efficient since we now open the file only once but requires that we depend on filepath package. Finally, readSymbolicLink is now defined via System.Directory.getSymbolicLinkTarget. * cleanup tests/LinksSpec.hs * fixed a comment in the tests explaining why we need the large threadDelay
1 parent 7a5f775 commit 7fc12d4

File tree

3 files changed

+159
-40
lines changed

3 files changed

+159
-40
lines changed

‎src/System/PosixCompat/Files.hsc‎

Lines changed: 45 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -122,6 +122,7 @@ setSymbolicLinkOwnerAndGroup _ _ _ = return ()
122122
import Control.Exception (bracket)
123123
import Control.Monad (liftM, liftM2)
124124
import Data.Bits ((.|.), (.&.))
125+
import Data.Char (toLower)
125126
import Data.Int (Int64)
126127
import Data.Time.Clock.POSIX (POSIXTime)
127128
import Foreign.C.Types (CTime(..))
@@ -133,10 +134,12 @@ import System.Directory (writable, setOwnerWritable)
133134
import System.Directory (executable, setOwnerExecutable)
134135
import System.Directory (searchable, setOwnerSearchable)
135136
import System.Directory (doesFileExist, doesDirectoryExist)
137+
import System.Directory (getSymbolicLinkTarget)
138+
import System.FilePath (takeExtension)
136139
import System.IO (IOMode(..), openFile, hSetFileSize, hClose)
137140
import System.IO.Error
138141
import System.PosixCompat.Types
139-
import System.Win32.File hiding (getFileType)
142+
import System.Win32.File
140143
import System.Win32.HardLink (createHardLink)
141144
import System.Win32.Time (FILETIME(..), getFileTime, setFileTime)
142145
import System.Win32.Types (HANDLE)
@@ -314,14 +317,23 @@ isSocket :: FileStatus -> Bool
314317
isSocket stat =
315318
(fileMode stat `intersectFileModes` fileTypeModes) == socketMode
316319

317-
getFileStatus :: FilePath -> IO FileStatus
318-
getFileStatus path = do
319-
perm <- liftM permsToMode (getPermissions path)
320-
typ <- getFileType path
320+
getStatus :: Bool -> FilePath -> IO FileStatus
321+
getStatus forLink path = do
321322
info <- bracket openPath closeHandle getFileInformationByHandle
322323
let atime = windowsToPosixTime (bhfiLastAccessTime info)
323324
mtime = windowsToPosixTime (bhfiLastWriteTime info)
324325
ctime = windowsToPosixTime (bhfiCreationTime info)
326+
attr = bhfiFileAttributes info
327+
isLink = attr .&. fILE_ATTRIBUTE_REPARSE_POINT /= 0
328+
isDir = attr .&. fILE_ATTRIBUTE_DIRECTORY /= 0
329+
isWritable = attr .&. fILE_ATTRIBUTE_READONLY == 0
330+
-- Contrary to Posix systems, directory symlinks on Windows have both
331+
-- fILE_ATTRIBUTE_REPARSE_POINT and fILE_ATTRIBUTE_DIRECTORY bits set.
332+
typ
333+
| isLink = symbolicLinkMode
334+
| isDir = directoryMode
335+
| otherwise = regularFileMode -- it's a lie but what can we do?
336+
perm = permissions path isWritable isDir
325337
return $ FileStatus
326338
{ deviceID = fromIntegral (bhfiVolumeSerialNumber info)
327339
, fileID = fromIntegral (bhfiFileIndex info)
@@ -340,13 +352,38 @@ getFileStatus path = do
340352
}
341353
where
342354
openPath = createFile path
343-
gENERIC_READ
355+
fILE_READ_EA
344356
(fILE_SHARE_READ .|. fILE_SHARE_WRITE .|. fILE_SHARE_DELETE)
345357
Nothing
346358
oPEN_EXISTING
347-
(sECURITY_ANONYMOUS .|. fILE_FLAG_BACKUP_SEMANTICS)
359+
(fILE_FLAG_BACKUP_SEMANTICS .|. openReparsePoint)
348360
Nothing
349361

362+
openReparsePoint = if forLink then fILE_FLAG_OPEN_REPARSE_POINT else 0
363+
364+
-- not yet defined in Win32 package:
365+
fILE_FLAG_OPEN_REPARSE_POINT :: FileAttributeOrFlag
366+
fILE_FLAG_OPEN_REPARSE_POINT = 0x00200000
367+
368+
-- Fused from System.Directory.Internal.Windows.getAccessPermissions
369+
-- and the former modeToPerms function.
370+
permissions path is_writable is_dir = r .|. w .|. x
371+
where
372+
is_executable =
373+
(toLower <$> takeExtension path) `elem` [".bat", ".cmd", ".com", ".exe"]
374+
r = ownerReadMode .|. groupReadMode .|. otherReadMode
375+
w = f is_writable (ownerWriteMode .|. groupWriteMode .|. otherWriteMode)
376+
x = f (is_executable || is_dir)
377+
(ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)
378+
f True m = m
379+
f False _ = nullFileMode
380+
381+
getSymbolicLinkStatus :: FilePath -> IO FileStatus
382+
getSymbolicLinkStatus = getStatus True
383+
384+
getFileStatus :: FilePath -> IO FileStatus
385+
getFileStatus = getStatus False
386+
350387
-- | Convert a 'POSIXTime' (synomym for 'Data.Time.Clock.NominalDiffTime')
351388
-- into an 'EpochTime' (integral number of seconds since epoch). This merely
352389
-- throws away the fractional part.
@@ -373,30 +410,9 @@ posixToWindowsTime t = FILETIME $
373410
truncate (t * 10000000 + windowsPosixEpochDifference)
374411
-}
375412

376-
permsToMode :: Permissions -> FileMode
377-
permsToMode perms = r .|. w .|. x
378-
where
379-
r = f (readable perms) (ownerReadMode .|. groupReadMode .|. otherReadMode)
380-
w = f (writable perms) (ownerWriteMode .|. groupWriteMode .|. otherWriteMode)
381-
x = f (executable perms || searchable perms)
382-
(ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)
383-
f True m = m
384-
f False _ = nullFileMode
385-
386-
getFileType :: FilePath -> IO FileMode
387-
getFileType path =
388-
do f <- doesFileExist path
389-
if f then return regularFileMode
390-
else do d <- doesDirectoryExist path
391-
if d then return directoryMode
392-
else unsupported "Unknown file type."
393-
394413
getFdStatus :: Fd -> IO FileStatus
395414
getFdStatus _ = unsupported "getFdStatus"
396415

397-
getSymbolicLinkStatus :: FilePath -> IO FileStatus
398-
getSymbolicLinkStatus path = getFileStatus path
399-
400416
createNamedPipe :: FilePath -> FileMode -> IO ()
401417
createNamedPipe _ _ = unsupported "createNamedPipe"
402418

@@ -419,7 +435,7 @@ createSymbolicLink :: FilePath -> FilePath -> IO ()
419435
createSymbolicLink _ _ = unsupported "createSymbolicLink"
420436

421437
readSymbolicLink :: FilePath -> IO FilePath
422-
readSymbolicLink _ = unsupported "readSymbolicLink"
438+
readSymbolicLink = getSymbolicLinkTarget
423439

424440
-- -----------------------------------------------------------------------------
425441
-- Renaming

‎tests/LinksSpec.hs‎

Lines changed: 108 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,122 @@
11
module LinksSpec(linksSpec) where
2-
import System.PosixCompat ( createSymbolicLink, removeLink, fileExist )
2+
3+
import Control.Concurrent ( threadDelay )
4+
import Control.Exception ( finally )
5+
import qualified System.Directory as D
6+
import System.Info ( os )
7+
import System.IO.Error ( tryIOError )
8+
import System.IO.Temp
9+
import System.PosixCompat
310
import Test.Hspec
411
import Test.HUnit
5-
import System.IO.Error (tryIOError)
6-
import System.Info(os)
7-
import Control.Monad.Extra (whenM)
812

913
isWindows :: Bool
1014
isWindows = os == "mingw32"
1115

1216
linksSpec :: Spec
13-
linksSpec = describe "createSymbolicLink" $ do
17+
linksSpec = do
18+
describe "createSymbolicLink" $ do
1419
it "should error on Windows and succeed on other OSes" $ do
15-
whenM (fileExist "README2.md") $ removeLink "README2.md"
16-
result <- tryIOError $ createSymbolicLink "README.md" "README2.md"
20+
runInTempDir $ do
21+
writeFile "file" ""
22+
result <- tryIOError $ createSymbolicLink "file" "file_link"
1723
case result of
1824
Left _ | isWindows -> return ()
1925
Right _ | isWindows -> do
20-
removeLink "README2.md"
2126
assertFailure "Succeeded while expected to fail on Windows"
2227
Left e -> assertFailure $ "Expected to succeed, but failed with " ++ show e
23-
Right _ -> removeLink "README2.md"
28+
Right _ -> return ()
29+
describe "getSymbolicLinkStatus" $ do
30+
it "should detect symbolic link to a file" $ do
31+
runFileLinkTest $ do
32+
stat <- getSymbolicLinkStatus "file_link"
33+
assert $ isSymbolicLink stat
34+
it "should detect symbolic link to a directory" $ do
35+
runDirLinkTest $ do
36+
stat <- getSymbolicLinkStatus "dir_link"
37+
assert $ isSymbolicLink stat
38+
it "should give later time stamp than getFileStatus for link to file" $ do
39+
runFileLinkTest $ do
40+
lstat_mtime <- modificationTimeHiRes <$> getSymbolicLinkStatus "file_link"
41+
stat_mtime <- modificationTimeHiRes <$> getFileStatus "file_link"
42+
assert $ lstat_mtime > stat_mtime
43+
it "should give later time stamp than getFileStatus for link to dir" $ do
44+
runDirLinkTest $ do
45+
lstat_mtime <- modificationTimeHiRes <$> getSymbolicLinkStatus "dir_link"
46+
stat_mtime <- modificationTimeHiRes <$> getFileStatus "dir_link"
47+
assert $ lstat_mtime > stat_mtime
48+
it "should give a different fileID than getFileStatus for link to file" $ do
49+
runFileLinkTest $ do
50+
lstat_id <- fileID <$> getSymbolicLinkStatus "file_link"
51+
fstat_id <- fileID <$> getFileStatus "file_link"
52+
assert $ lstat_id /= fstat_id
53+
it "should give a different fileID than getFileStatus for link to dir" $ do
54+
runDirLinkTest $ do
55+
lstat_id <- fileID <$> getSymbolicLinkStatus "dir_link"
56+
fstat_id <- fileID <$> getFileStatus "dir_link"
57+
assert $ lstat_id /= fstat_id
58+
describe "getFileStatus" $ do
59+
it "should detect that symbolic link target is a file" $ do
60+
runFileLinkTest $ do
61+
stat <- getFileStatus "file_link"
62+
assert $ isRegularFile stat
63+
it "should detect that symbolic link target is a directory" $ do
64+
runDirLinkTest $ do
65+
stat <- getFileStatus "dir_link"
66+
assert $ isDirectory stat
67+
it "should be equal for link and link target (except access time)" $ do
68+
runFileLinkTest $ do
69+
fstat <- getFileStatus "file"
70+
flstat <- getFileStatus "file_link"
71+
assert $ fstat `mostlyEq` flstat
72+
runDirLinkTest $ do
73+
fstat <- getFileStatus "dir"
74+
flstat <- getFileStatus "dir_link"
75+
assert $ fstat `mostlyEq` flstat
76+
77+
where
78+
79+
runFileLinkTest action =
80+
runInTempDir $ do
81+
writeFile "file" ""
82+
threadDelay delay
83+
D.createFileLink "file" "file_link"
84+
action
85+
86+
runDirLinkTest action =
87+
runInTempDir $ do
88+
D.createDirectory "dir"
89+
threadDelay delay
90+
D.createDirectoryLink "dir" "dir_link"
91+
action
92+
93+
runInTempDir action = do
94+
orig <- D.getCurrentDirectory
95+
withTempDirectory orig "xxxxxxx" $ \tmp -> do
96+
D.setCurrentDirectory tmp
97+
action `finally` D.setCurrentDirectory orig
98+
99+
-- We need to set the delay this high because otherwise the timestamp test
100+
-- above fails on Linux and Windows, though not on MacOS. This seems to be
101+
-- an artefact of the GHC runtime system which gives two subsequently
102+
-- created files the same timestamp unless the delay is large enough.
103+
delay = 10000
104+
105+
-- Test equality for all parts except accessTime
106+
mostlyEq :: FileStatus -> FileStatus -> Bool
107+
mostlyEq x y = tuple x == tuple y
108+
where
109+
tuple s =
110+
( deviceID s
111+
, fileID s
112+
, fileMode s
113+
, linkCount s
114+
, fileOwner s
115+
, fileGroup s
116+
, specialDeviceID s
117+
, fileSize s
118+
, modificationTime s
119+
, statusChangeTime s
120+
, modificationTimeHiRes s
121+
, statusChangeTimeHiRes s
122+
)

‎unix-compat.cabal‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,7 @@ Library
4646

4747
extra-libraries: msvcrt
4848
build-depends: Win32 >= 2.5.0.0
49+
build-depends: filepath >= 1.0 && < 1.5
4950

5051
if flag(old-time)
5152
build-depends: old-time >= 1.0.0.0 && < 1.2.0.0
@@ -58,7 +59,7 @@ Library
5859
build-depends: directory == 1.1.*
5960
else
6061
build-depends: time >= 1.0 && < 1.13
61-
build-depends: directory >= 1.2 && < 1.4
62+
build-depends: directory >= 1.3.1 && < 1.4
6263

6364
other-modules:
6465
System.PosixCompat.Internal.Time
@@ -106,6 +107,7 @@ Test-Suite unix-compat-testsuite
106107
, HUnit
107108
, directory
108109
, extra
110+
, temporary
109111

110112
if os(windows)
111113
-- c-sources:
@@ -126,7 +128,7 @@ Test-Suite unix-compat-testsuite
126128
build-depends: directory == 1.1.*
127129
else
128130
build-depends: time >= 1.0 && < 1.13
129-
build-depends: directory >= 1.2 && < 1.4
131+
build-depends: directory >= 1.3.1 && < 1.4
130132

131133
-- other-modules:
132134
-- System.PosixCompat.Internal.Time
@@ -139,3 +141,5 @@ Test-Suite unix-compat-testsuite
139141
-- c-sources: cbits/HsUnixCompat.c
140142
if os(solaris)
141143
cc-options: -DSOLARIS
144+
145+
build-depends: directory >= 1.3.1 && < 1.4

0 commit comments

Comments
 (0)