hsfm/src/HSFM/FileSystem/FileOperations.hs

{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
--}

{-# OPTIONS_HADDOCK ignore-exports #-}
{-# LANGUAGE PackageImports #-}

-- |This module provides all the atomic IO related file operations like
-- copy, delete, move and so on. It operates primarily on `AnchoredFile`, which
-- is guaranteed to be well-formed.
--
-- It would be nicer to pass states around, but the filesystem state changes
-- too quickly and cannot be relied upon. Lazy implementations of filesystem
-- trees have been tried as well, but they can introduce subtle bugs.
module HSFM.FileSystem.FileOperations where


import Control.Exception
  (
    throw
  )
import Control.Monad
  (
    unless
  )
import Data.Foldable
  (
    for_
  )
import Foreign.C.Error
  (
    eXDEV
  )
import HPath
    (
      Path
    , Abs
    , Fn
    )
import qualified HPath as P
import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileType
import HSFM.Utils.IO
import System.Posix.Directory
  (
    createDirectory
  , removeDirectory
  )
import System.Posix.Files
  (
    createSymbolicLink
  , fileMode
  , readSymbolicLink
  , getSymbolicLinkStatus
  , groupExecuteMode
  , groupReadMode
  , groupWriteMode
  , otherExecuteMode
  , otherReadMode
  , otherWriteMode
  , ownerModes
  , ownerReadMode
  , ownerWriteMode
  , rename
  , unionFileModes
  , removeLink
  )
import qualified "unix" System.Posix.IO as SPI
import "unix-bytestring" System.Posix.IO.ByteString
  (
    fdWrite
  )
import System.Posix.Types
  (
    FileMode
  )
import System.Process
  (
    spawnProcess
  , ProcessHandle
  )

import qualified Data.ByteString  as BS



-- TODO: file operations should be threaded and not block the UI
-- TODO: make sure we do the right thing for BlockDev, CharDev etc...
--       most operations are not implemented for these


-- |Data type describing an actual file operation that can be
-- carried out via `doFile`. Useful to build up a list of operations
-- or delay operations.
data FileOperation = FCopy    Copy
                   | FMove    Move
                   | FDelete  (AnchoredFile FileInfo)
                   | FOpen    (AnchoredFile FileInfo)
                   | FExecute (AnchoredFile FileInfo) [String]
                   | None


-- |Data type describing partial or complete file copy operation.
-- CC stands for a complete operation and can be used for `runFileOp`.
data Copy = CP1 (AnchoredFile FileInfo)
          | CP2 (AnchoredFile FileInfo)
                (AnchoredFile FileInfo)
          | CC  (AnchoredFile FileInfo)
                (AnchoredFile FileInfo)
                CopyMode


-- |Data type describing partial or complete file move operation.
-- MC stands for a complete operation and can be used for `runFileOp`.
data Move = MP1 (AnchoredFile FileInfo)
          | MC  (AnchoredFile FileInfo)
                (AnchoredFile FileInfo)
                CopyMode


-- |Copy modes.
data CopyMode = Strict  -- ^ fail if the target already exists
              | Merge   -- ^ overwrite files if necessary, for files, this
                        --   is the same as Replace
              | Replace -- ^ remove targets before copying, this is
                        --   only useful if the target is a directorty


-- |Run a given FileOperation. If the FileOperation is partial, it will
-- be returned.
runFileOp :: FileOperation -> IO (Maybe FileOperation)
runFileOp (FCopy (CC from to cm)) = easyCopy cm from to >> return Nothing
runFileOp (FCopy fo)              = return              $ Just $ FCopy fo
runFileOp (FMove (MC from to cm)) = moveFile cm from to >> return Nothing
runFileOp (FMove fo)              = return              $ Just $ FMove fo
runFileOp (FDelete fp)            = easyDelete fp       >> return Nothing
runFileOp (FOpen fp)              = openFile fp         >> return Nothing
runFileOp (FExecute fp args)      = executeFile fp args >> return Nothing
runFileOp _                       = return Nothing



    --------------------
    --[ File Copying ]--
    --------------------


-- TODO: allow renaming
-- |Copies a directory to the given destination with the specified
-- `DirCopyMode`. Excludes symlinks.
copyDir :: CopyMode
        -> AnchoredFile FileInfo  -- ^ source dir
        -> AnchoredFile FileInfo  -- ^ destination dir
        -> IO ()
copyDir _ AFileInvFN _ = throw InvalidFileName
copyDir _ _ AFileInvFN = throw InvalidFileName
copyDir cm from@(_ :/ Dir fromn FileInfo{ fileMode = fmode })
             to@(_ :/ Dir {})
  = do
    let fromp    = fullPath from
        top      = fullPath to
        destdirp = top P.</> fromn
    throwDestinationInSource fromp destdirp
    throwSameFile fromp destdirp
    throwCantOpenDirectory fromp
    throwCantOpenDirectory top

    createDestdir destdirp fmode
    destdir <- HSFM.FileSystem.FileType.readFileWithFileInfo destdirp

    contents <- readDirectoryContents' (fullPath from)

    for_ contents $ \f ->
      case f of
        (_ :/ SymLink {})  -> recreateSymlink cm f destdir
        (_ :/ Dir {})      -> copyDir cm f destdir
        (_ :/ RegFile {})  -> copyFileToDir Replace f destdir
        _                  -> return ()
  where
    createDestdir destdir fmode' =
      let destdir' = P.toFilePath destdir
      in case cm of
        Merge   ->
          unlessM (doesDirectoryExist destdir)
                  (createDirectory destdir' fmode')
        Strict  -> do
          throwDirDoesExist destdir
          createDirectory destdir' fmode'
        Replace -> do
          whenM (doesDirectoryExist destdir)
                (deleteDirRecursive =<<
                   HSFM.FileSystem.FileType.readFileWithFileInfo destdir)
          createDirectory destdir' fmode'
copyDir _ _ _ = throw $ InvalidOperation "wrong input type"


-- |Recreate a symlink.
recreateSymlink :: CopyMode
                -> AnchoredFile FileInfo  -- ^ the old symlink file
                -> AnchoredFile FileInfo  -- ^ destination dir of the
                                          --   new symlink file
                -> IO ()
recreateSymlink _ AFileInvFN _ = throw InvalidFileName
recreateSymlink _ _ AFileInvFN = throw InvalidFileName
recreateSymlink cm    symf@(_ :/ SymLink {})
                   symdest@(_ :/ Dir {})
  = do
    throwCantOpenDirectory $ fullPath symdest
    sympoint <- readSymbolicLink (fullPathS $ symf)
    let symname = fullPath symdest P.</> (name . file $ symf)
    case cm of
      Merge   -> delOld symname
      Replace -> delOld symname
      _       -> return ()
    createSymbolicLink sympoint (P.fromAbs symname)
  where
    delOld symname = do
      f <- HSFM.FileSystem.FileType.readFileWithFileInfo symname
      unless (failed . file $ f)
             (easyDelete f)
recreateSymlink _ _ _ = throw $ InvalidOperation "wrong input type"


-- |TODO: handle EAGAIN exception for non-blocking IO
-- |Low-level function to copy a given file to the given path. The fileMode
-- is preserved. The file is always overwritten if accessible.
copyFile' :: Path Abs -> Path Abs -> IO ()
copyFile' from to = do
  let from' = P.fromAbs from
      to'   = P.fromAbs to
  throwCantOpenDirectory $ P.dirname from
  throwCantOpenDirectory $ P.dirname to
  fromFstatus <- getSymbolicLinkStatus from'
  fromContent <- BS.readFile from'
  fd          <- SPI.createFile to'
                   (System.Posix.Files.fileMode fromFstatus)
  _ <- fdWrite fd fromContent
  SPI.closeFd fd


-- |Copies the given file to the given file destination, overwriting it.
-- Excludes symlinks.
overwriteFile :: AnchoredFile FileInfo  -- ^ source file
              -> AnchoredFile FileInfo  -- ^ destination file
              -> IO ()
overwriteFile AFileInvFN _ = throw InvalidFileName
overwriteFile _ AFileInvFN = throw InvalidFileName
overwriteFile from@(_ :/ RegFile {})
                to@(_ :/ RegFile {})
  = do
    let from' = fullPath from
        to'   = fullPath to
    throwCantOpenDirectory $ P.dirname from'
    throwCantOpenDirectory $ P.dirname to'
    throwSameFile from' to'
    copyFile' from' to'
overwriteFile _ _ = throw $ InvalidOperation "wrong input type"


-- |Copies the given file to the given dir with the same filename.
-- Excludes symlinks.
copyFileToDir :: CopyMode
              -> AnchoredFile FileInfo
              -> AnchoredFile FileInfo
              -> IO ()
copyFileToDir _ AFileInvFN _ = throw InvalidFileName
copyFileToDir _ _ AFileInvFN = throw InvalidFileName
copyFileToDir cm from@(_ :/ RegFile fn _)
                   to@(_ :/ Dir {})
  = do
    let from' = fullPath from
        to'   = fullPath to P.</> fn
    throwCantOpenDirectory $ fullPath to
    case cm of
      Strict -> throwFileDoesExist to'
      _      -> return ()
    copyFile' from' to'
copyFileToDir _ _ _ = throw $ InvalidOperation "wrong input type"


-- |Copies a file, directory or symlink. In case of a symlink, it is just
-- recreated, even if it points to a directory.
easyCopy :: CopyMode
         -> AnchoredFile FileInfo
         -> AnchoredFile FileInfo
         -> IO ()
easyCopy cm from@(_ :/ SymLink{})
              to@(_ :/ Dir{})
  = recreateSymlink cm from to
easyCopy cm from@(_ :/ RegFile{})
              to@(_ :/ Dir{})
  = copyFileToDir cm from to
easyCopy cm from@(_ :/ Dir{})
              to@(_ :/ Dir{})
  = copyDir cm from to
easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"





    ---------------------
    --[ File Deletion ]--
    ---------------------


-- |Deletes a symlink, which can either point to a file or directory.
deleteSymlink :: AnchoredFile FileInfo -> IO ()
deleteSymlink AFileInvFN = throw InvalidFileName
deleteSymlink f@(_ :/ SymLink {})
  = removeLink (P.toFilePath . fullPath $ f)
deleteSymlink _ = throw $ InvalidOperation "wrong input type"


-- |Deletes the given file, never symlinks.
deleteFile :: AnchoredFile FileInfo -> IO ()
deleteFile AFileInvFN = throw InvalidFileName
deleteFile f@(_ :/ RegFile {})
  = removeLink (P.toFilePath . fullPath $ f)
deleteFile _ = throw $ InvalidOperation "wrong input type"


-- |Deletes the given directory, never symlinks.
deleteDir :: AnchoredFile FileInfo -> IO ()
deleteDir AFileInvFN = throw InvalidFileName
deleteDir f@(_ :/ Dir {})
  = removeDirectory (P.toFilePath . fullPath $ f)
deleteDir _ = throw $ InvalidOperation "wrong input type"


-- |Deletes the given directory recursively.
deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
deleteDirRecursive AFileInvFN = throw InvalidFileName
deleteDirRecursive f@(_ :/ Dir {}) = do
  let fp = fullPath f
  throwCantOpenDirectory fp
  files <- readDirectoryContents' fp
  for_ files $ \file ->
    case file of
      (_ :/ SymLink {}) -> deleteSymlink file
      (_ :/ Dir {})     -> deleteDirRecursive file
      (_ :/ RegFile {}) -> removeLink (P.toFilePath . fullPath $ file)
      _                 -> throw $ FileDoesExist (P.toFilePath . fullPath $ file)
  removeDirectory . P.toFilePath $ fp
deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"


-- |Deletes a file, directory or symlink, whatever it may be.
-- In case of directory, performs recursive deletion. In case of
-- a symlink, the symlink file is deleted.
easyDelete :: AnchoredFile FileInfo -> IO ()
easyDelete f@(_ :/ SymLink {}) = deleteSymlink f
easyDelete f@(_ :/ RegFile {})
  = deleteFile f
easyDelete f@(_ :/ Dir {})
  = deleteDirRecursive f
easyDelete _ = throw $ InvalidOperation "wrong input type"




    --------------------
    --[ File Opening ]--
    --------------------


-- |Opens a file appropriately by invoking xdg-open.
openFile :: AnchoredFile a
         -> IO ProcessHandle
openFile AFileInvFN = throw InvalidFileName
openFile f = spawnProcess "xdg-open" [fullPathS f]


-- |Executes a program with the given arguments.
executeFile :: AnchoredFile FileInfo  -- ^ program
            -> [String]               -- ^ arguments
            -> IO ProcessHandle
executeFile AFileInvFN _ = throw InvalidFileName
executeFile prog@(_ :/ RegFile {}) args
  = spawnProcess (fullPathS prog) args
executeFile _ _ = throw $ InvalidOperation "wrong input type"




    ---------------------
    --[ File Creation ]--
    ---------------------


createFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
createFile AFileInvFN _ = throw InvalidFileName
createFile _ InvFN      = throw InvalidFileName
createFile (ADirOrSym td) (ValFN fn) = do
  let fullp = fullPath td P.</> fn
  throwFileDoesExist fullp
  fd <- SPI.createFile (P.fromAbs fullp) newFilePerms
  SPI.closeFd fd
createFile _ _ = throw $ InvalidOperation "wrong input type"


createDir :: AnchoredFile FileInfo -> Path Fn -> IO ()
createDir AFileInvFN _ = throw InvalidFileName
createDir _ InvFN      = throw InvalidFileName
createDir (ADirOrSym td) (ValFN fn) = do
  let fullp = fullPath td P.</> fn
  throwDirDoesExist fullp
  createDirectory (P.fromAbs fullp) newFilePerms
createDir _ _ = throw $ InvalidOperation "wrong input type"




    ----------------------------
    --[ File Renaming/Moving ]--
    ----------------------------


renameFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
renameFile AFileInvFN _ = throw InvalidFileName
renameFile _ InvFN      = throw InvalidFileName
renameFile af (ValFN fn) = do
  let fromf = fullPath af
      tof   = anchor af P.</> fn
  throwFileDoesExist tof
  throwSameFile fromf tof
  rename (P.fromAbs fromf) (P.fromAbs tof)
renameFile _ _ = throw $ InvalidOperation "wrong input type"


-- |Move a given file to the given target directory.
moveFile :: CopyMode
         -> AnchoredFile FileInfo -- ^ file to move
         -> AnchoredFile FileInfo -- ^ base target directory
         -> IO ()
moveFile _ AFileInvFN _ = throw InvalidFileName
moveFile _ _ AFileInvFN = throw InvalidFileName
moveFile cm from to@(_ :/ Dir {}) = do
  let from'  = fullPath from
      froms' = fullPathS from
      to'    = fullPath to P.</> (name . file $ from)
      tos'   = P.fromAbs (fullPath to P.</> (name . file $ from))
  case cm of
    Strict  -> throwFileDoesExist to'
    Merge   -> delOld to'
    Replace -> delOld to'
  throwSameFile from' to'
  catchErrno eXDEV (rename froms' tos') $ do
    easyCopy Strict from to
    easyDelete from
  where
    delOld fp = do
      to' <- HSFM.FileSystem.FileType.readFileWithFileInfo fp
      unless (failed . file $ to') (easyDelete to')
moveFile _ _ _ = throw $ InvalidOperation "wrong input type"





    -----------------------
    --[ File Permissions]--
    -----------------------


newFilePerms :: FileMode
newFilePerms
  =                  ownerWriteMode
    `unionFileModes` ownerReadMode
    `unionFileModes` groupWriteMode
    `unionFileModes` groupReadMode
    `unionFileModes` otherWriteMode
    `unionFileModes` otherReadMode


newDirPerms :: FileMode
newDirPerms
  =                  ownerModes
    `unionFileModes` groupExecuteMode
    `unionFileModes` groupReadMode
    `unionFileModes` otherExecuteMode
    `unionFileModes` otherReadMode