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