lehins · lehins · Apr 18, 2019 · Apr 18, 2019 · Apr 22, 2019
diff --git a/rio/src/RIO/File.hs b/rio/src/RIO/File.hs
@@ -203,6 +203,8 @@ openFileFromDir (Fd dirFd) fp iomode =
   withFilePath fp $ \f -> do
     bracketOnError
       (do fileFd <- throwErrnoIfMinus1Retry "openFileFromDir" $
+                      -- FIXME: `openat` requires for the file path to be
+                      -- relative to the directory if the file path is not absolute.
                       c_safe_openat dirFd f (ioModeToFlags iomode)
                                             0o666 {- Can open directory with read only -}
           FD.mkFD
@@ -262,6 +264,10 @@ buildTemporaryFilePath filePath = liftIO $ do
   let
     dirFp  = takeDirectory filePath
     fileFp = takeFileName filePath
+  -- FIXME: By using a temporary file on the file system we are not protecting
+  -- ourselves from other processes ability to remove the file from under our
+  -- feet. Using `O_TMPFILE` when opening and `linkat` instead of renaming would
+  -- be a better solution. Thanks Niklas for suggestion.
   bracket (openBinaryTempFile dirFp fileFp)
           (hClose . snd)
           (return . fst)
@@ -309,6 +315,10 @@ closeFileDurableAtomic tmpFilePath filePath dirFd@(Fd cDirFd) fileHandle = do
            fsyncFileDescriptor "closeFileDurableAtomic/Directory" cDirFd)
       (closeDirectory dirFd)
   where
+    -- FIXME: Renamed source and destination files must both have absolute
+    -- paths, if any one of them is relative, then both must be located in the
+    -- `dirFd` and the ones that are relative, must have file names relative to
+    -- the `dirFd`, i.e. have the prefix relative path stripped. This is the cause of rio#160
     renameFile tmpFp origFp =
       void $
       throwErrnoIfMinus1Retry "closeFileDurableAtomic - renameFile" $
@@ -402,6 +412,8 @@ withBinaryFileDurable absFp iomode cb =
 #if WINDOWS
   withBinaryFile absFp iomode cb
 #else
+  -- FIXME: ReadMode does not require any syncing, as such should be treated
+  -- specially, but it's not.
   withRunInIO $ \run ->
     bracket
       (openFileAndDirectory absFp iomode)
@@ -461,13 +473,28 @@ withBinaryFileDurableAtomic absFp iomode cb = do
         -- copy original file for read purposes
         fileExists <- doesFileExist absFp
         tmpFp <- toTmpFilePath absFp
+        -- FIXME: Possible race condition: between `doesFileExist` and `when
+        -- fileExists` could be removed, which would result in a runtime
+        -- exception, but should be ignored instead and write file operation
+        -- should start with an empty file
+
+        -- FIXME: Because copyFile closes the handle, fsync no longer guarantees
+        -- that the copied data will be durable
+        --
+        -- FIXME: permissions of the original file are not saved, consequently
+        -- aren't restored after atomic rename
         when fileExists $ copyFile absFp tmpFp
+        -- FIXME: exception here will simply leave a copy of a file dangling
 
         withDurableAtomic tmpFp run
   where
     withDurableAtomic tmpFp run = do
       bracket
         (openFileAndDirectory tmpFp iomode)
-        (uncurry $ closeFileDurableAtomic tmpFp absFp)
+        (uncurry $ closeFileDurableAtomic tmpFp absFp
+         -- FIXME: An exception in `cb` would cause a corrupt file getting
+         -- atomically renamed here
+         -- FIXME: An exception here would cause a temporary file be left dangling
+        )
         (run . cb . snd)
 #endif
diff --git a/rio/test/RIO/FileSpec.hs b/rio/test/RIO/FileSpec.hs
@@ -1,53 +1,153 @@
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module RIO.FileSpec where
 
-import Test.Hspec
 import System.FilePath ((</>))
+import Test.Hspec
+import Test.QuickCheck
+import UnliftIO.Directory
 import UnliftIO.Temporary (withSystemTempDirectory)
 
 import RIO
 import qualified RIO.ByteString as BS
-import qualified RIO.File as SUT
+import qualified RIO.File as File
+
+data ExpectedException =
+  ExpectedException
+  deriving (Show)
+
+instance Exception ExpectedException
 
 spec :: Spec
 spec = do
-  describe "ensureFileDurable" $ do
+  describe "ensureFileDurable" $
     it "ensures a file is durable with an fsync" $
       withSystemTempDirectory "rio" $ \dir -> do
         let fp = dir </> "ensure_file_durable"
         writeFileUtf8 fp "Hello World"
-        SUT.ensureFileDurable fp
+        File.ensureFileDurable fp
         contents <- BS.readFile fp
         contents `shouldBe` "Hello World"
+  withBinaryFileSpec False "withBinaryFile" withBinaryFile
+  writeBinaryFileSpec "writeBinaryFile" writeFileBinary
+  -- Above two specs are validating the specs behavior by applying to
+  -- known good implementations
+  -- withBinaryFileSpec True "withBinaryFileAtomic" File.withBinaryFileAtomic
+  -- writeBinaryFileSpec "writeBinaryFileAtomic" File.writeBinaryFileAtomic
+  withBinaryFileSpec False "withBinaryFileDurable" File.withBinaryFileDurable
+  writeBinaryFileSpec "writeBinaryFileDurable" File.writeBinaryFileDurable
+  withBinaryFileSpec True "withBinaryFileDurableAtomic" File.withBinaryFileDurableAtomic
+  writeBinaryFileSpec "writeBinaryFileDurableAtomic" File.writeBinaryFileDurableAtomic
 
-  describe "withBinaryFileDurableAtomic" $ do
-    context "read/write" $ do
-      it "works correctly" $ do
+withBinaryFileSpec ::
+     Bool -- ^ Should we test atomicity
+  -> String
+  -> (forall a. FilePath -> IOMode -> (Handle -> IO a) -> IO a)
+  -> Spec
+withBinaryFileSpec atomic fname withFileTestable = do
+  let hello = "Hello World"
+      writeHello fp = writeFileUtf8Builder fp $ displayBytesUtf8 hello
+      -- Create a file, write "Hello World" into it and apply the action.
+      withHelloFileTestable fp iomode action = do
+        writeHello fp
+        withFileTestable fp iomode action
+      goodbye = "Goodbye World"
+      modifiedPermissions =
+        setOwnerExecutable True $
+        setOwnerReadable True $ setOwnerWritable True emptyPermissions
+  describe fname $ do
+    it "read" $
+      withSystemTempDirectory "rio" $ \dir -> do
+        let fp = dir </> fname ++ "-read"
+        withHelloFileTestable fp ReadMode BS.hGetContents `shouldReturn` hello
+    it "write" $
+      withSystemTempDirectory "rio" $ \dir -> do
+        let fp = dir </> fname ++ "-write"
+        withHelloFileTestable fp WriteMode (`BS.hPut` goodbye)
+        BS.readFile fp `shouldReturn` goodbye
+    it "read/write" $
+      withSystemTempDirectory "rio" $ \dir -> do
+        let fp = dir </> fname ++ "-read-write"
+        withHelloFileTestable fp ReadWriteMode $ \h -> do
+          BS.hGetLine h `shouldReturn` hello
+          BS.hPut h goodbye
+        BS.readFile fp `shouldReturn` (hello <> goodbye)
+    it "append" $
+      withSystemTempDirectory "rio" $ \dir -> do
+        let fp = dir </> fname ++ "-append"
+            privet = "Привет Мир" -- some unicode won't hurt
+        writeFileUtf8Builder fp $ display privet
+        setPermissions fp modifiedPermissions
+        withFileTestable fp AppendMode $ \h -> BS.hPut h goodbye
+        BS.readFile fp `shouldReturn` (encodeUtf8 privet <> goodbye)
+    it "sub-directory" $
+      withSystemTempDirectory "rio" $ \dir -> do
+        let subDir = dir </> fname ++ "-sub-directory"
+            fp = subDir </> "test.file"
+        createDirectoryIfMissing True subDir
+        withHelloFileTestable fp ReadWriteMode $ \h -> do
+          BS.hGetLine h `shouldReturn` hello
+          BS.hPut h goodbye
+        BS.readFile fp `shouldReturn` (hello <> goodbye)
+    it "relative-directory" $
+      withSystemTempDirectory "rio" $ \dir -> do
+        let relDir = fname ++ "-relative-directory"
+            subDir = dir </> relDir
+            fp = relDir </> "test.file"
+        createDirectoryIfMissing True subDir
+        withCurrentDirectory dir $ do
+          withHelloFileTestable fp ReadWriteMode $ \h -> do
+            BS.hGetLine h `shouldReturn` hello
+            BS.hPut h goodbye
+          BS.readFile fp `shouldReturn` (hello <> goodbye)
+    it "modified-permissions" $
+      forAll (elements [WriteMode, ReadWriteMode, AppendMode]) $ \iomode ->
         withSystemTempDirectory "rio" $ \dir -> do
-          let fp = dir </> "ensure_file_durable_atomic"
-          writeFileUtf8 fp "Hello World"
-          SUT.withBinaryFileDurableAtomic fp ReadWriteMode $ \h -> do
-            input <- BS.hGetLine h
-            input `shouldBe` "Hello World"
-            BS.hPut h "Goodbye World"
-
-    context "happy path" $ do
-      it "works the same as withFile" $ do
+          let fp = dir </> fname ++ "-modified-permissions"
+          writeHello fp
+          setPermissions fp modifiedPermissions
+          withFileTestable fp iomode $ \h -> BS.hPut h goodbye
+          getPermissions fp `shouldReturn` modifiedPermissions
+    it "exception - Does not corrupt files" $
+      bool expectFailure id atomic $ -- should fail for non-atomic
+      forAll (elements [WriteMode, ReadWriteMode, AppendMode]) $ \iomode ->
         withSystemTempDirectory "rio" $ \dir -> do
-          let fp = dir </> "with_file_durable_atomic"
-          SUT.withBinaryFileDurableAtomic fp WriteMode $ \h ->
-            BS.hPut h "Hello World"
-          contents <- BS.readFile fp
-          contents `shouldBe` "Hello World"
-
-  describe "withBinaryFileDurable" $ do
-    context "happy path" $ do
-      it "works the same as withFile" $ do
+          let fp = dir </> fname ++ "-exception"
+          _ :: Either ExpectedException () <-
+            try $
+            withHelloFileTestable fp iomode $ \h -> do
+              BS.hPut h goodbye
+              throwIO ExpectedException
+          BS.readFile fp `shouldReturn` hello
+    it "exception - Does not leave files behind" $
+      bool expectFailure id atomic $ -- should fail for non-atomic
+      forAll (elements [WriteMode, ReadWriteMode, AppendMode]) $ \iomode ->
         withSystemTempDirectory "rio" $ \dir -> do
-          let fp = dir </> "with_file_durable"
-          SUT.withBinaryFileDurable fp WriteMode $ \h ->
-            BS.hPut h "Hello World"
-          contents <- BS.readFile fp
-          contents `shouldBe` "Hello World"
+          let fp = dir </> fname ++ "-exception"
+          _ :: Either ExpectedException () <-
+            try $
+            withFileTestable fp iomode $ \h -> do
+              BS.hPut h goodbye
+              throwIO ExpectedException
+          doesFileExist fp `shouldReturn` False
+          listDirectory dir `shouldReturn` []
+
+writeBinaryFileSpec :: String -> (FilePath -> ByteString -> IO ()) -> SpecWith ()
+writeBinaryFileSpec fname writeFileTestable = do
+  let hello = "Hello World"
+      defaultPermissions =
+        setOwnerReadable True $ setOwnerWritable True emptyPermissions
+  describe fname $ do
+    it "write" $
+      withSystemTempDirectory "rio" $ \dir -> do
+        let fp = dir </> fname ++ "-write"
+        writeFileTestable fp hello
+        BS.readFile fp `shouldReturn` hello
+    it "default-permissions" $
+      withSystemTempDirectory "rio" $ \dir -> do
+        let fp = dir </> fname ++ "-default-permissions"
+        writeFileTestable fp hello
+        getPermissions fp `shouldReturn` defaultPermissions