File.hs

-- | Working with the file system.
module BuildBox.Command.File
	( PropFile(..)
	, inDir
	, inScratchDir
	, clobberDir
	, ensureDir
	, withTempFile
	, atomicWriteFile
        , exe )
where
import BuildBox.Build
import System.Directory
import Control.Exception
import Control.Monad.State
import System.Info

-- | Properties of the file system we can test for.
data PropFile

	-- | Some executable is in the current path.
	= HasExecutable	String

	-- | Some file exists.
	| HasFile	FilePath

	-- | Some directory exists.
	| HasDir  	FilePath

	-- | Some file is empty.
	| FileEmpty 	FilePath
	deriving Show


instance Testable PropFile where
 test prop
  = case prop of
	HasExecutable name
	 -> do	bin <- io $ findExecutable name
		return $ case bin of
		 Just _	 	-> True
		 Nothing 	-> False

	HasFile path
	 -> io $ doesFileExist path

	HasDir  path
	 -> io $ doesDirectoryExist path

	FileEmpty  path
	 -> do	contents	<- io $ readFile path
		return (null contents)


-- | Run a command in a different working directory. Throws an error if the directory doesn't exist.
inDir :: FilePath -> Build a -> Build a
inDir name build
 = do	check $ HasDir name
	oldDir	<- io $ getCurrentDirectory

	io $ setCurrentDirectory name
	x	<- build
	io $ setCurrentDirectory oldDir

	return x

-- | Create a new directory with the given name, run a command within it,
--   then change out and recursively delete the directory. Throws an error if a directory
--   with the given name already exists.
inScratchDir :: FilePath -> Build a -> Build a
inScratchDir name build
 = do
	-- Make sure a dir with this name doesn't already exist.
	checkFalse $ HasDir name

	ensureDir name
	x	<- inDir name build
	clobberDir name

	return x


-- | Delete a dir recursively if it's there, otherwise do nothing.
clobberDir :: FilePath -> Build ()
clobberDir path
 = do	e <- io $ try $ removeDirectoryRecursive path
 	case (e :: Either SomeException ()) of
 	 _	-> return ()


-- | Create a new directory if it isn't already there, or return successfully if it is.
ensureDir :: FilePath -> Build ()
ensureDir path
 = do	already	<- io $ doesDirectoryExist path
	if already
	 then return ()
	 else do e <- io $ try $ createDirectoryIfMissing True path
	 	 case (e :: Either SomeException ()) of
		  _	-> return ()


-- | Create a temp file, pass it to some command, then delete the file after the command finishes.
withTempFile :: (FilePath -> Build a) -> Build a
withTempFile build
 = do	fileName	<- newTempFile

	-- run the real command
	result	<- build fileName

	-- cleanup
	io $ removeFile fileName

	return result


-- | Allocate a new temporary file name
newTempFile :: Build FilePath
newTempFile
 = do	buildDir	<- gets buildStateScratchDir
	buildId		<- gets buildStateId
	buildSeq	<- gets buildStateSeq

	-- Increment the sequence number.
	modify $ \s -> s { buildStateSeq = buildStateSeq s + 1 }

        -- Ensure the build directory exists, or canonicalizePath will fail
        ensureDir buildDir

	-- Build the file name we'll try to use.
	-- We need to account for a blank scratch directory, otherwise there is
	-- no way to use the CD as a scratch on Windows.
	let fileName	 = (if (null buildDir) then "" else (buildDir ++ "/"))
		++ "buildbox-" ++ show buildId ++ "-" ++ show buildSeq
                                                -- TODO: normalise path

	-- If it already exists then something has gone badly wrong.
	--   Maybe the unique Id for the process wasn't as unique as we thought.
	exists		<- io $ doesFileExist fileName
	when exists
	 $ error "buildbox: panic, supposedly fresh file already exists."

	-- Touch the file for good measure.
	--   If the unique id wasn't then we want to detect this.
	io $ writeFile fileName ""

	io $ canonicalizePath fileName


-- | Atomically write a file by first writing it to a tmp file then renaming it.
--   This prevents concurrent processes from reading half-written files.
atomicWriteFile :: FilePath -> String -> Build ()
atomicWriteFile filePath str
 = do	tmp	<- newTempFile
	io $ writeFile tmp str
	e <- io $ try $ renameFile tmp filePath

	-- renameFile may not be able to rename files across physical devices, 
	-- depending on the implementation. If renameFile fails then try copyFile.
	case (e :: Either SomeException ()) of
	 Right _ 	   
 	  -> return ()

	 Left _
 	  -> do	io $ copyFile tmp filePath
		io $ removeFile tmp
		return ()


-- | The file extension for an executable on the current system.
exe :: String
exe
 | os == "mingw32"      = "exe"
 | otherwise            = ""