FileUtil.hs

{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

{-|

Description: Utility code for file IO with 'RawFilePath's.

-}

module Data.Git.Internal.FileUtil where

import           Control.Applicative
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import qualified Data.ByteString         as B
import qualified Data.ByteString.Lazy    as BL
import           System.IO
import           System.IO.Error         (catchIOError, isAlreadyExistsError, isDoesNotExistError,
                                          isPermissionError, tryIOError)
import           System.Posix.ByteString
import           System.Posix.FilePath

-- | A somewhat more involved version of 'System.IO.withFile'.
withHandle :: NFData a => Maybe FileMode -> OpenMode -> RawFilePath -> OpenFileFlags -> (Handle -> IO a) -> IO a
withHandle c m p offs app = bracket (fdToHandle =<< openFd p m c offs) hClose (\h -> app h >>= (\r -> r `deepseq` return r))

-- | Uses 'mkstemp' (with the given path as the filename template) instead of the 'withHandle'
--   machinery to open the temp file.  The awkward type in the callback is to let the user compute
--   the name of the output file---when @'Just' tgt@, the temp file is 'rename'd to @tgt@, otherwise
--   we use the template.
withHandleAtomic :: NFData a => RawFilePath -> (Handle -> IO (Maybe RawFilePath, a)) -> IO a
withHandleAtomic p app = bracketOnError (mkstemp p) cleanup go
    where cleanup (tmp, h) = hClose h >> removeLink tmp
          go (tmp, h)      = do
            (np, force -> !r) <- app h
            hClose h
            rename tmp $ maybe p id np
            return r

-- | An open temp file.
data TempFile = TempFile
    { tempHandle    :: Handle
    -- | The filename 'mkstemp' came up with.
    , tempFileName  :: RawFilePath
    -- | Template given to 'mkstemp' for this file.
    , tempTemplate  :: RawFilePath
    -- | When given 'Nothing', deletes the temp file, when given @'Just' tgt@, @rename@s the temp
    --   file to @tgt@.
    , closeTempFile :: Maybe RawFilePath -> IO ()
    }

-- | Make a 'TempFile' using the given 'RawFilePath' as a template for 'mkstemp'.
tempFile :: RawFilePath -> IO TempFile
tempFile p = do
  createRawDirectoryIfMissing True (dropFileName p)
  bracketOnError (mkstemp p) cleanup go
  where
    cleanup   (tmp, h)           = hClose h >> removeLink tmp
    go      t@(tmp, h)           = return $ TempFile h tmp p (finish t)
    finish  t  Nothing           = cleanup t
    finish    (tmp, h) (Just np) = rename tmp np >> hClose h

readFileFlags :: OpenFileFlags
-- | Flags to open a file for reading
readFileFlags  = defaultFileFlags

-- | Read a file into a lazy 'BL.ByteString'.
readRawFileL :: RawFilePath -> IO BL.ByteString
readRawFileL p = withHandle Nothing ReadOnly p readFileFlags BL.hGetContents

-- | Read a file into a strict 'B.ByteString'.
readRawFileS :: RawFilePath -> IO B.ByteString
readRawFileS p = withHandle Nothing ReadOnly p readFileFlags B.hGetContents

-- | Write a lazy 'BL.ByteString' to a file via 'withHandleAtomic'.
writeRawFileL :: RawFilePath -> BL.ByteString -> IO ()
writeRawFileL p bs = withHandleAtomic p (\h -> BL.hPut h bs *> return (Nothing, ()))

-- | Write a strict 'B.ByteString' to a file via 'withHandleAtomic'.
writeRawFileS :: RawFilePath -> B.ByteString -> IO ()
writeRawFileS p bs = withHandleAtomic p (\h -> B.hPut h bs *> return (Nothing, ()))

-- | Do something when a file exists.
whenFileExists :: MonadIO m =>
                 RawFilePath
               -> a   -- ^ Return this when the file doesn't exist.
               -> m a -- ^ Do this when it does.
               -> m a
whenFileExists p a io = do
  exists <- liftIO $ fileExist p
  if exists
  then io
  else return a

-- | Like 'whenFileExists', with 'empty' as a default.
mwhenFileExists :: (MonadIO m, Alternative f) => RawFilePath -> m a -> m (f a)
mwhenFileExists p io = whenFileExists p empty (pure <$> io)

-- | Lists the files in a directory.
getRawDirectoryContents :: RawFilePath -> IO [RawFilePath]
getRawDirectoryContents dir = bracket (openDirStream dir) closeDirStream go
    where go ds = do f  <- readDirStream ds
                     if f == ""
                     then return []
                     else (f:) <$> go ds

-- | This is stolen directly from 'System.Directory.createDirectoryIfMissing', swapped to use
-- functions from 'System.Posix.FilePath'.  NB: due to the absence of a @normalise@ function in the
-- latter module, this function doesn't do any normalization.
createRawDirectoryIfMissing :: Bool -> RawFilePath -> IO ()
createRawDirectoryIfMissing create_parents path0
  | create_parents = createDirs (parents path0)
  | otherwise      = createDirs (take 1 (parents path0))
  where
    parents = reverse . scanl1 (</>) . splitDirectories {- . normalise -}

    createDirs []         = return ()
    createDirs (dir:[])   = createDir dir ioError
    createDirs (dir:dirs) =
      createDir dir $ \_ -> do
        createDirs dirs
        createDir dir ioError

    createDir dir notExistHandler = do
      r <- tryIOError (createDirectory dir dirmode)
      case r of
        Right ()                   -> return ()
        Left  e
          | isDoesNotExistError  e -> notExistHandler e
          | isAlreadyExistsError e
            || isPermissionError    e -> do
              canIgnore <- isDir `catchIOError` \ _ ->
                           return (isAlreadyExistsError e)
              unless canIgnore (ioError e)
          | otherwise              -> ioError e
      where
        isDir = (isDirectory <$> getFileStatus dir)
    dirmode  = foldr unionFileModes directoryMode dirmodes
    dirmodes = [ ownerModes,
                 groupReadMode, groupExecuteMode
               , otherReadMode, otherExecuteMode ]

-- | A version of 'System.Directory.withCurrentDirectory' using a 'RawFilePath'.
withRawCurrentDirectory :: RawFilePath -> IO a -> IO a
withRawCurrentDirectory dir action =
  bracket getWorkingDirectory changeWorkingDirectory $ \ _ -> do
    changeWorkingDirectory dir
    action