Declare language extensions via `{-# LANGUAGE -#}`
[packages/unix.git] / tests / fileStatus.hs
1
2 -- GHC trac #2969
3
4 import System.Posix.Files
5 import System.Posix.Directory
6 import System.Posix.IO
7 import Control.Exception as E
8 import Control.Monad
9
10 main = do
11 cleanup
12 fs <- testRegular
13 ds <- testDir
14 testSymlink fs ds
15 cleanup
16
17 regular = "regular"
18 dir = "dir"
19 link_regular = "link-regular"
20 link_dir = "link-dir"
21
22 testRegular = do
23 createFile regular ownerReadMode
24 (fs, _) <- getStatus regular
25 let expected = (False,False,False,True,False,False,False)
26 actual = snd (statusElements fs)
27 when (actual /= expected) $
28 fail "unexpected file status bits for regular file"
29 return fs
30
31 testDir = do
32 createDirectory dir ownerReadMode
33 (ds, _) <- getStatus dir
34 let expected = (False,False,False,False,True,False,False)
35 actual = snd (statusElements ds)
36 when (actual /= expected) $
37 fail "unexpected file status bits for directory"
38 return ds
39
40 testSymlink fs ds = do
41 createSymbolicLink regular link_regular
42 createSymbolicLink dir link_dir
43 (fs', ls) <- getStatus link_regular
44 (ds', lds) <- getStatus link_dir
45
46 let expected = (False,False,False,False,False,True,False)
47 actualF = snd (statusElements ls)
48 actualD = snd (statusElements lds)
49
50 when (actualF /= expected) $
51 fail "unexpected file status bits for symlink to regular file"
52
53 when (actualD /= expected) $
54 fail "unexpected file status bits for symlink to directory"
55
56 when (statusElements fs /= statusElements fs') $
57 fail "status for a file does not match when it's accessed via a symlink"
58
59 when (statusElements ds /= statusElements ds') $
60 fail "status for a directory does not match when it's accessed via a symlink"
61
62 cleanup = do
63 ignoreIOExceptions $ removeDirectory dir
64 mapM_ (ignoreIOExceptions . removeLink)
65 [regular, link_regular, link_dir]
66
67 ignoreIOExceptions io = io `E.catch`
68 ((\_ -> return ()) :: IOException -> IO ())
69
70 getStatus f = do
71 fs <- getFileStatus f
72 ls <- getSymbolicLinkStatus f
73
74 fd <- openFd f ReadOnly Nothing defaultFileFlags
75 fs' <- getFdStatus fd
76
77 when (statusElements fs /= statusElements fs') $
78 fail "getFileStatus and getFdStatus give inconsistent results"
79
80 when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $
81 fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results "
82 ++ "on a file that is not a symbolic link"
83
84 return (fs, ls)
85
86 -- Yay for 20-element tuples!
87 statusElements fs = (,)
88 (deviceID fs
89 ,fileMode fs
90 ,linkCount fs
91 ,fileOwner fs
92 ,fileGroup fs
93 ,specialDeviceID fs
94 ,fileSize fs
95 ,accessTime fs
96 ,accessTimeHiRes fs
97 ,modificationTime fs
98 ,modificationTimeHiRes fs
99 ,statusChangeTime fs
100 ,statusChangeTimeHiRes fs
101 )
102 (isBlockDevice fs
103 ,isCharacterDevice fs
104 ,isNamedPipe fs
105 ,isRegularFile fs
106 ,isDirectory fs
107 ,isSymbolicLink fs
108 ,isSocket fs
109 )