FileSpec.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module UnliftIO.IO.FileSpec where

import Test.Hspec
-- Atomic/durable file writing is not supported on Windows.
#ifndef WINDOWS
import Control.Monad (forM_)
import Data.Bool (bool)
import System.FilePath ((</>))
import Test.QuickCheck
import UnliftIO.Directory
import UnliftIO.Exception
import UnliftIO.IO
import UnliftIO.IO.File as File
import UnliftIO.Temporary (withSystemTempDirectory)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
#if __GLASGOW_HASKELL__ < 820
import Data.Monoid
#endif

data ExpectedException =
  ExpectedException
  deriving (Show)

instance Exception ExpectedException

spec :: Spec
spec = do
  describe "ensureFileDurable" $
    it "ensures a file is durable with an fsync" $
      withSystemTempDirectory "rio" $ \dir -> do
        let fp = dir </> "ensure_file_durable"
        writeFile fp "Hello World"
        File.ensureFileDurable fp
        contents <- B.readFile fp
        contents `shouldBe` "Hello World"
  withBinaryFileSpec False "withBinaryFile" withBinaryFile
  writeBinaryFileSpec "writeBinaryFile" writeBinaryFile
  -- 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

writeFileUtf8 fp str = withBinaryFile fp WriteMode (`BB.hPutBuilder` BB.stringUtf8 str)

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"
      helloString = "Hello World"
      writeHello fp = writeFileUtf8 fp helloString
      -- 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 yall"
      modifiedPermissions =
        setOwnerExecutable True $
        setOwnerReadable True $ setOwnerWritable True emptyPermissions
  describe fname $ do
    it "read" $
      withSystemTempDirectory "rio" $ \dir -> do
        let fp = dir </> fname ++ "-read"
        withHelloFileTestable fp ReadWriteMode (`B.hGet` B.length hello) `shouldReturn`
          hello
    it "write" $
      withSystemTempDirectory "rio" $ \dir -> do
        let fp = dir </> fname ++ "-write"
        withHelloFileTestable fp WriteMode (`B.hPut` goodbye)
        B.readFile fp `shouldReturn` goodbye
    it "read/write" $
      withSystemTempDirectory "rio" $ \dir -> do
        let fp = dir </> fname ++ "-read-write"
        withHelloFileTestable fp ReadWriteMode $ \h -> do
          B.hGetLine h `shouldReturn` hello
          B.hPut h goodbye
        B.readFile fp `shouldReturn` (hello <> goodbye)
    it "append" $
      withSystemTempDirectory "rio" $ \dir -> do
        let fp = dir </> fname ++ "-append"
            privet = "Привет Мир" -- some unicode won't hurt
            encodeUtf8 = BL.toStrict . BB.toLazyByteString . BB.stringUtf8
        writeFileUtf8 fp privet
        setPermissions fp modifiedPermissions
        withFileTestable fp AppendMode $ \h -> B.hPut h goodbye
        B.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
          B.hGetLine h `shouldReturn` hello
          B.hPut h goodbye
        B.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
        withCurrentDirectoryCompat dir $ do
          withHelloFileTestable fp ReadWriteMode $ \h -> do
            B.hGetLine h `shouldReturn` hello
            B.hPut h goodbye
          B.readFile fp `shouldReturn` (hello <> goodbye)
    it "modified-permissions" $
      forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->
        withSystemTempDirectory "rio" $ \dir -> do
          let fp = dir </> fname ++ "-modified-permissions"
          writeHello fp
          setPermissions fp modifiedPermissions
          withFileTestable fp iomode $ \h -> B.hPut h goodbye
          getPermissions fp `shouldReturn` modifiedPermissions
    it "exception - Does not corrupt files" $
      bool expectFailure property atomic $ -- should fail for non-atomic
      forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->
        withSystemTempDirectory "rio" $ \dir -> do
          let fp = dir </> fname ++ "-exception"
          _ :: Either ExpectedException () <-
            try $
            withHelloFileTestable fp iomode $ \h -> do
              B.hPut h goodbye
              throwIO ExpectedException
          B.readFile fp `shouldReturn` hello
    it "exception - Does not leave files behind" $
      bool expectFailure property atomic $ -- should fail for non-atomic
      forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->
        withSystemTempDirectory "rio" $ \dir -> do
          let fp = dir </> fname ++ "-exception"
          _ :: Either ExpectedException () <-
            try $
            withFileTestable fp iomode $ \h -> do
              B.hPut h goodbye
              throwIO ExpectedException
          doesFileExist fp `shouldReturn` False
          listDirectoryCompat dir `shouldReturn` []
    it "delete - file" $
      bool expectFailure property atomic $ -- should fail for non-atomic
      forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->
        withSystemTempDirectory "rio" $ \dir -> do
          let fp = dir </> fname ++ "-delete"
          withHelloFileTestable fp iomode $ \h -> do
            removeFile fp
            B.hPut h goodbye
          doesFileExist fp `shouldReturn` True

writeBinaryFileSpec :: String -> (FilePath -> B.ByteString -> IO ()) -> SpecWith ()
writeBinaryFileSpec fname writeFileTestable = do
  let hello = "Hello World"
  describe fname $ do
    it "write" $
      withSystemTempDirectory "rio" $ \dir -> do
        let fp = dir </> fname ++ "-write"
        writeFileTestable fp hello
        B.readFile fp `shouldReturn` hello
    it "default-permissions" $
      withSystemTempDirectory "rio" $ \dir -> do
        let fp = dir </> fname ++ "-default-permissions"
            defaultPermissions =
              setOwnerReadable True $ setOwnerWritable True emptyPermissions
        writeFileTestable fp hello
        getPermissions fp `shouldReturn` defaultPermissions


listDirectoryCompat :: FilePath -> IO [FilePath]
#if MIN_VERSION_directory(1,2,5)
listDirectoryCompat = listDirectory
#else
listDirectoryCompat path =
  filter f <$> getDirectoryContents path
  where f filename = filename /= "." && filename /= ".."
#endif

withCurrentDirectoryCompat :: FilePath -> IO a -> IO a
#if MIN_VERSION_directory(1,2,3)
withCurrentDirectoryCompat = withCurrentDirectory
#else
withCurrentDirectoryCompat dir action =
  bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do
    setCurrentDirectory dir
    action
#endif

#else
spec :: Spec
spec = pure ()
#endif