1{-# LANGUAGE CPP #-}
2{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6module UnliftIO.IO.FileSpec where
7
8import Test.Hspec
9-- Atomic/durable file writing is not supported on Windows.
10#ifndef WINDOWS
11import Control.Monad (forM_)
12import Data.Bool (bool)
13import System.FilePath ((</>))
14import Test.QuickCheck
15import UnliftIO.Directory
16import UnliftIO.Exception
17import UnliftIO.IO
18import UnliftIO.IO.File as File
19import UnliftIO.Temporary (withSystemTempDirectory)
20import qualified Data.ByteString as B
21import qualified Data.ByteString.Builder as BB
22import qualified Data.ByteString.Lazy as BL
23#if __GLASGOW_HASKELL__ < 820
24import Data.Monoid
25#endif
26
27data ExpectedException =
28  ExpectedException
29  deriving (Show)
30
31instance Exception ExpectedException
32
33spec :: Spec
34spec = do
35  describe "ensureFileDurable" $
36    it "ensures a file is durable with an fsync" $
37      withSystemTempDirectory "rio" $ \dir -> do
38        let fp = dir </> "ensure_file_durable"
39        writeFile fp "Hello World"
40        File.ensureFileDurable fp
41        contents <- B.readFile fp
42        contents `shouldBe` "Hello World"
43  withBinaryFileSpec False "withBinaryFile" withBinaryFile
44  writeBinaryFileSpec "writeBinaryFile" writeBinaryFile
45  -- Above two specs are validating the specs behavior by applying to
46  -- known good implementations
47  withBinaryFileSpec True "withBinaryFileAtomic" File.withBinaryFileAtomic
48  writeBinaryFileSpec "writeBinaryFileAtomic" File.writeBinaryFileAtomic
49  withBinaryFileSpec False "withBinaryFileDurable" File.withBinaryFileDurable
50  writeBinaryFileSpec "writeBinaryFileDurable" File.writeBinaryFileDurable
51  withBinaryFileSpec True "withBinaryFileDurableAtomic" File.withBinaryFileDurableAtomic
52  writeBinaryFileSpec "writeBinaryFileDurableAtomic" File.writeBinaryFileDurableAtomic
53
54writeFileUtf8 fp str = withBinaryFile fp WriteMode (`BB.hPutBuilder` BB.stringUtf8 str)
55
56withBinaryFileSpec ::
57     Bool -- ^ Should we test atomicity
58  -> String
59  -> (forall a. FilePath -> IOMode -> (Handle -> IO a) -> IO a)
60  -> Spec
61withBinaryFileSpec atomic fname withFileTestable = do
62  let hello = "Hello World"
63      helloString = "Hello World"
64      writeHello fp = writeFileUtf8 fp helloString
65      -- Create a file, write "Hello World" into it and apply the action.
66      withHelloFileTestable fp iomode action = do
67        writeHello fp
68        withFileTestable fp iomode action
69      goodbye = "Goodbye yall"
70      modifiedPermissions =
71        setOwnerExecutable True $
72        setOwnerReadable True $ setOwnerWritable True emptyPermissions
73  describe fname $ do
74    it "read" $
75      withSystemTempDirectory "rio" $ \dir -> do
76        let fp = dir </> fname ++ "-read"
77        withHelloFileTestable fp ReadWriteMode (`B.hGet` B.length hello) `shouldReturn`
78          hello
79    it "write" $
80      withSystemTempDirectory "rio" $ \dir -> do
81        let fp = dir </> fname ++ "-write"
82        withHelloFileTestable fp WriteMode (`B.hPut` goodbye)
83        B.readFile fp `shouldReturn` goodbye
84    it "read/write" $
85      withSystemTempDirectory "rio" $ \dir -> do
86        let fp = dir </> fname ++ "-read-write"
87        withHelloFileTestable fp ReadWriteMode $ \h -> do
88          B.hGetLine h `shouldReturn` hello
89          B.hPut h goodbye
90        B.readFile fp `shouldReturn` (hello <> goodbye)
91    it "append" $
92      withSystemTempDirectory "rio" $ \dir -> do
93        let fp = dir </> fname ++ "-append"
94            privet = "Привет Мир" -- some unicode won't hurt
95            encodeUtf8 = BL.toStrict . BB.toLazyByteString . BB.stringUtf8
96        writeFileUtf8 fp privet
97        setPermissions fp modifiedPermissions
98        withFileTestable fp AppendMode $ \h -> B.hPut h goodbye
99        B.readFile fp `shouldReturn` (encodeUtf8 privet <> goodbye)
100    it "sub-directory" $
101      withSystemTempDirectory "rio" $ \dir -> do
102        let subDir = dir </> fname ++ "-sub-directory"
103            fp = subDir </> "test.file"
104        createDirectoryIfMissing True subDir
105        withHelloFileTestable fp ReadWriteMode $ \h -> do
106          B.hGetLine h `shouldReturn` hello
107          B.hPut h goodbye
108        B.readFile fp `shouldReturn` (hello <> goodbye)
109    it "relative-directory" $
110      withSystemTempDirectory "rio" $ \dir -> do
111        let relDir = fname ++ "-relative-directory"
112            subDir = dir </> relDir
113            fp = relDir </> "test.file"
114        createDirectoryIfMissing True subDir
115        withCurrentDirectoryCompat dir $ do
116          withHelloFileTestable fp ReadWriteMode $ \h -> do
117            B.hGetLine h `shouldReturn` hello
118            B.hPut h goodbye
119          B.readFile fp `shouldReturn` (hello <> goodbye)
120    it "modified-permissions" $
121      forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->
122        withSystemTempDirectory "rio" $ \dir -> do
123          let fp = dir </> fname ++ "-modified-permissions"
124          writeHello fp
125          setPermissions fp modifiedPermissions
126          withFileTestable fp iomode $ \h -> B.hPut h goodbye
127          getPermissions fp `shouldReturn` modifiedPermissions
128    it "exception - Does not corrupt files" $
129      bool expectFailure property atomic $ -- should fail for non-atomic
130      forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->
131        withSystemTempDirectory "rio" $ \dir -> do
132          let fp = dir </> fname ++ "-exception"
133          _ :: Either ExpectedException () <-
134            try $
135            withHelloFileTestable fp iomode $ \h -> do
136              B.hPut h goodbye
137              throwIO ExpectedException
138          B.readFile fp `shouldReturn` hello
139    it "exception - Does not leave files behind" $
140      bool expectFailure property atomic $ -- should fail for non-atomic
141      forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->
142        withSystemTempDirectory "rio" $ \dir -> do
143          let fp = dir </> fname ++ "-exception"
144          _ :: Either ExpectedException () <-
145            try $
146            withFileTestable fp iomode $ \h -> do
147              B.hPut h goodbye
148              throwIO ExpectedException
149          doesFileExist fp `shouldReturn` False
150          listDirectoryCompat dir `shouldReturn` []
151    it "delete - file" $
152      bool expectFailure property atomic $ -- should fail for non-atomic
153      forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->
154        withSystemTempDirectory "rio" $ \dir -> do
155          let fp = dir </> fname ++ "-delete"
156          withHelloFileTestable fp iomode $ \h -> do
157            removeFile fp
158            B.hPut h goodbye
159          doesFileExist fp `shouldReturn` True
160
161writeBinaryFileSpec :: String -> (FilePath -> B.ByteString -> IO ()) -> SpecWith ()
162writeBinaryFileSpec fname writeFileTestable = do
163  let hello = "Hello World"
164  describe fname $ do
165    it "write" $
166      withSystemTempDirectory "rio" $ \dir -> do
167        let fp = dir </> fname ++ "-write"
168        writeFileTestable fp hello
169        B.readFile fp `shouldReturn` hello
170    it "default-permissions" $
171      withSystemTempDirectory "rio" $ \dir -> do
172        let fp = dir </> fname ++ "-default-permissions"
173            defaultPermissions =
174              setOwnerReadable True $ setOwnerWritable True emptyPermissions
175        writeFileTestable fp hello
176        getPermissions fp `shouldReturn` defaultPermissions
177
178
179listDirectoryCompat :: FilePath -> IO [FilePath]
180#if MIN_VERSION_directory(1,2,5)
181listDirectoryCompat = listDirectory
182#else
183listDirectoryCompat path =
184  filter f <$> getDirectoryContents path
185  where f filename = filename /= "." && filename /= ".."
186#endif
187
188withCurrentDirectoryCompat :: FilePath -> IO a -> IO a
189#if MIN_VERSION_directory(1,2,3)
190withCurrentDirectoryCompat = withCurrentDirectory
191#else
192withCurrentDirectoryCompat dir action =
193  bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do
194    setCurrentDirectory dir
195    action
196#endif
197
198#else
199spec :: Spec
200spec = pure ()
201#endif
202