Restructure module layout
This commit is contained in:
172
src/HSFM/FileSystem/Errors.hs
Normal file
172
src/HSFM/FileSystem/Errors.hs
Normal file
@@ -0,0 +1,172 @@
|
||||
{--
|
||||
HSFM, a filemanager written in Haskell.
|
||||
Copyright (C) 2015 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 DeriveDataTypeable #-}
|
||||
|
||||
-- |Provides error handling.
|
||||
module HSFM.FileSystem.Errors where
|
||||
|
||||
|
||||
import Control.Applicative
|
||||
(
|
||||
(<$>)
|
||||
)
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
(
|
||||
unless
|
||||
, void
|
||||
, when
|
||||
)
|
||||
import Data.List
|
||||
(
|
||||
isPrefixOf
|
||||
)
|
||||
import Data.Typeable
|
||||
import Foreign.C.Error
|
||||
(
|
||||
getErrno
|
||||
, Errno
|
||||
)
|
||||
import HSFM.Utils.IO
|
||||
import System.FilePath
|
||||
(
|
||||
equalFilePath
|
||||
, isAbsolute
|
||||
, takeFileName
|
||||
)
|
||||
import System.IO.Error
|
||||
(
|
||||
catchIOError
|
||||
)
|
||||
|
||||
import qualified System.Posix.Files as PF
|
||||
|
||||
|
||||
data FmIOException = FileDoesNotExist String
|
||||
| DirDoesNotExist String
|
||||
| PathNotAbsolute String
|
||||
| FileNotExecutable String
|
||||
| SameFile String String
|
||||
| NotAFile String
|
||||
| NotADir String
|
||||
| DestinationInSource String String
|
||||
| FileDoesExist String
|
||||
| DirDoesExist String
|
||||
| IsSymlink String
|
||||
| InvalidOperation String
|
||||
| InvalidFileName
|
||||
deriving (Show, Typeable)
|
||||
|
||||
|
||||
instance Exception FmIOException
|
||||
|
||||
|
||||
-- Throws an exception if the filepath is not absolute
|
||||
-- or the file does not exist.
|
||||
fileSanityThrow :: FilePath -> IO ()
|
||||
fileSanityThrow fp = throwNotAbsolute fp >> throwFileDoesNotExist fp
|
||||
|
||||
|
||||
-- Throws an exception if the filepath is not absolute
|
||||
-- or the dir does not exist.
|
||||
dirSanityThrow :: FilePath -> IO ()
|
||||
dirSanityThrow fp = throwNotAbsolute fp >> throwDirDoesNotExist fp
|
||||
|
||||
|
||||
throwNotAbsolute :: FilePath -> IO ()
|
||||
throwNotAbsolute fp = unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
|
||||
|
||||
|
||||
throwFileDoesExist :: FilePath -> IO ()
|
||||
throwFileDoesExist fp =
|
||||
whenM (doesFileExist fp) (throw $ FileDoesExist fp)
|
||||
|
||||
|
||||
throwDirDoesExist :: FilePath -> IO ()
|
||||
throwDirDoesExist fp =
|
||||
whenM (doesDirectoryExist fp) (throw $ DirDoesExist fp)
|
||||
|
||||
|
||||
throwDirDoesNotExist :: FilePath -> IO ()
|
||||
throwDirDoesNotExist fp =
|
||||
unlessM (doesDirectoryExist fp) (throw $ DirDoesNotExist fp)
|
||||
|
||||
|
||||
throwFileDoesNotExist :: FilePath -> IO ()
|
||||
throwFileDoesNotExist fp =
|
||||
unlessM (doesFileExist fp) (throw $ FileDoesNotExist fp)
|
||||
|
||||
|
||||
throwSameFile :: FilePath -- ^ should be canonicalized
|
||||
-> FilePath -- ^ should be canonicalized
|
||||
-> IO ()
|
||||
throwSameFile fp1 fp2 = when (equalFilePath fp1 fp2) (throw $ SameFile fp1 fp2)
|
||||
|
||||
|
||||
throwDestinationInSource :: FilePath -- ^ should be canonicalized
|
||||
-> FilePath -- ^ should be canonicalized
|
||||
-> IO ()
|
||||
throwDestinationInSource source dest =
|
||||
when (source `isPrefixOf` dest) (throw $ DestinationInSource dest source)
|
||||
|
||||
|
||||
throwIsSymlink :: FilePath -> IO ()
|
||||
throwIsSymlink fp =
|
||||
whenM (PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp)
|
||||
(throw $ IsSymlink fp)
|
||||
|
||||
|
||||
-- |Carries out an action, then checks if there is an IOException and
|
||||
-- a specific errno. If so, then it carries out another action, otherwise
|
||||
-- it rethrows the error.
|
||||
catchErrno :: Errno -- ^ errno to catch
|
||||
-> IO a -- ^ action to try, which can raise an IOException
|
||||
-> IO a -- ^ action to carry out in case of an IOException and
|
||||
-- if errno matches
|
||||
-> IO a
|
||||
catchErrno en a1 a2 =
|
||||
catchIOError a1 $ \e -> do
|
||||
errno <- getErrno
|
||||
if errno == en
|
||||
then a2
|
||||
else ioError e
|
||||
|
||||
|
||||
handleIOError :: (IOError -> IO a) -> IO a -> IO a
|
||||
handleIOError a1 a2 = catchIOError a2 a1
|
||||
|
||||
|
||||
-- |Checks if the given file exists and is not a directory. This follows
|
||||
-- symlinks, but will return True if the symlink is broken.
|
||||
doesFileExist :: FilePath -> IO Bool
|
||||
doesFileExist fp =
|
||||
handleIOError (\_ -> return False) $ do
|
||||
fs <- catchIOError (PF.getFileStatus fp) $ \_ ->
|
||||
PF.getSymbolicLinkStatus fp
|
||||
return $ not . PF.isDirectory $ fs
|
||||
|
||||
|
||||
-- |Checks if the given file exists and is a directory. This follows
|
||||
-- symlinks, but will return False if the symlink is broken.
|
||||
doesDirectoryExist :: FilePath -> IO Bool
|
||||
doesDirectoryExist fp =
|
||||
handleIOError (\_ -> return False) $ do
|
||||
fs <- PF.getFileStatus fp
|
||||
return $ PF.isDirectory fs
|
||||
496
src/HSFM/FileSystem/FileOperations.hs
Normal file
496
src/HSFM/FileSystem/FileOperations.hs
Normal file
@@ -0,0 +1,496 @@
|
||||
{--
|
||||
HSFM, a filemanager written in Haskell.
|
||||
Copyright (C) 2015 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 #-}
|
||||
|
||||
-- |This module provides all the atomic IO related file operations like
|
||||
-- copy, delete, move and so on. It operates only on FilePaths and reads
|
||||
-- all necessary file information manually in order to stay atomic and not
|
||||
-- rely on the state of passed objects.
|
||||
--
|
||||
-- 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.Applicative
|
||||
(
|
||||
(<$>)
|
||||
)
|
||||
import Control.Exception
|
||||
(
|
||||
throw
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
unless
|
||||
)
|
||||
import Data.Foldable
|
||||
(
|
||||
for_
|
||||
)
|
||||
import Foreign.C.Error
|
||||
(
|
||||
eXDEV
|
||||
)
|
||||
import HPath
|
||||
(
|
||||
Path
|
||||
, Fn
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HSFM.FileSystem.Errors
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.Utils.IO
|
||||
import HSFM.Utils.MyPrelude
|
||||
import System.FilePath
|
||||
(
|
||||
(</>)
|
||||
)
|
||||
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 System.Posix.IO
|
||||
(
|
||||
closeFd
|
||||
, createFile
|
||||
)
|
||||
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
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--[ 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
|
||||
fromp' = P.toFilePath fromp
|
||||
top = fullPath to
|
||||
destdirp = top P.</> fromn
|
||||
destdirp' = P.toFilePath destdirp
|
||||
throwDestinationInSource fromp' destdirp'
|
||||
throwSameFile fromp' destdirp'
|
||||
|
||||
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
|
||||
sympoint <- readSymbolicLink (P.fromAbs . fullPath $ 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' :: FilePath -> FilePath -> IO ()
|
||||
copyFile' from to = do
|
||||
fromFstatus <- getSymbolicLinkStatus from
|
||||
fromContent <- BS.readFile from
|
||||
fd <- System.Posix.IO.createFile to
|
||||
(System.Posix.Files.fileMode fromFstatus)
|
||||
closeFd fd
|
||||
BS.writeFile to fromContent
|
||||
|
||||
|
||||
-- |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' = P.fromAbs . fullPath $ from
|
||||
to' = P.fromAbs . fullPath $ 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' = P.fromAbs . fullPath $ from
|
||||
to' = P.fromAbs (fullPath to P.</> fn)
|
||||
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 fn _)
|
||||
to@(_ :/ Dir {})
|
||||
= copyFileToDir cm from to
|
||||
easyCopy cm from@(_ :/ Dir fn _)
|
||||
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"
|
||||
|
||||
|
||||
-- TODO: check if we have permissions at all to remove the directory,
|
||||
-- before we go recursively messing with it
|
||||
-- |Deletes the given directory recursively.
|
||||
deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
|
||||
deleteDirRecursive AFileInvFN = throw InvalidFileName
|
||||
deleteDirRecursive f@(_ :/ Dir {}) = do
|
||||
let fp = fullPath f
|
||||
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" [P.fromAbs . fullPath $ 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 (P.fromAbs . fullPath $ 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 = P.fromAbs (fullPath td P.</> fn)
|
||||
throwFileDoesExist fullp
|
||||
fd <- System.Posix.IO.createFile fullp newFilePerms
|
||||
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 = P.fromAbs (fullPath td P.</> fn)
|
||||
throwDirDoesExist fullp
|
||||
createDirectory 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 = P.fromAbs . fullPath $ af
|
||||
tof = P.fromAbs (anchor af P.</> fn)
|
||||
throwFileDoesExist tof
|
||||
throwSameFile fromf tof
|
||||
rename fromf 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' = P.fromAbs . fullPath $ from
|
||||
to' = fullPath to P.</> (name . file $ from)
|
||||
tos' = P.fromAbs (fullPath to P.</> (name . file $ from))
|
||||
case cm of
|
||||
Strict -> throwFileDoesExist tos'
|
||||
Merge -> delOld to'
|
||||
Replace -> delOld to'
|
||||
throwSameFile froms' tos'
|
||||
catchErrno eXDEV (rename froms' tos') $ do
|
||||
easyCopy Strict from to
|
||||
easyDelete from
|
||||
where
|
||||
delOld to = do
|
||||
to' <- HSFM.FileSystem.FileType.readFileWithFileInfo to
|
||||
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
|
||||
809
src/HSFM/FileSystem/FileType.hs
Normal file
809
src/HSFM/FileSystem/FileType.hs
Normal file
@@ -0,0 +1,809 @@
|
||||
{--
|
||||
HSFM, a filemanager written in Haskell.
|
||||
Copyright (C) 2015 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 #-}
|
||||
|
||||
-- |This module provides data types for representing directories/files
|
||||
-- and related operations on it, mostly internal stuff, not actual IO actions.
|
||||
--
|
||||
-- It doesn't allow to represent the whole filesystem, since that's only
|
||||
-- possible through IO laziness, which introduces too much internal state.
|
||||
module HSFM.FileSystem.FileType where
|
||||
|
||||
|
||||
import Control.Applicative
|
||||
(
|
||||
(<*>)
|
||||
, (<$>)
|
||||
, (<|>)
|
||||
, pure
|
||||
)
|
||||
import Control.Arrow
|
||||
(
|
||||
first
|
||||
)
|
||||
import Control.Exception
|
||||
(
|
||||
handle
|
||||
)
|
||||
import Control.Exception.Base
|
||||
(
|
||||
onException
|
||||
, IOException
|
||||
)
|
||||
import Control.Monad.State.Lazy
|
||||
(
|
||||
|
||||
)
|
||||
import Data.Default
|
||||
import Data.List
|
||||
(
|
||||
delete
|
||||
, foldl'
|
||||
, isPrefixOf
|
||||
, sort
|
||||
, sortBy
|
||||
, (\\)
|
||||
)
|
||||
import Data.Maybe
|
||||
(
|
||||
catMaybes
|
||||
, fromMaybe
|
||||
)
|
||||
import Data.Ord
|
||||
(
|
||||
comparing
|
||||
)
|
||||
import Data.Time.Clock.POSIX
|
||||
(
|
||||
POSIXTime
|
||||
, posixSecondsToUTCTime
|
||||
)
|
||||
import Data.Time
|
||||
(
|
||||
UTCTime(..)
|
||||
)
|
||||
import Data.Traversable
|
||||
(
|
||||
for
|
||||
)
|
||||
import Data.Word
|
||||
(
|
||||
Word64
|
||||
)
|
||||
import HPath
|
||||
(
|
||||
Abs
|
||||
, Path
|
||||
, Fn
|
||||
, Rel
|
||||
, pattern Path
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HSFM.Utils.MyPrelude
|
||||
import Safe
|
||||
(
|
||||
atDef
|
||||
, initDef
|
||||
)
|
||||
import System.FilePath
|
||||
(
|
||||
combine
|
||||
, normalise
|
||||
, equalFilePath
|
||||
, isAbsolute
|
||||
, joinPath
|
||||
, pathSeparator
|
||||
, splitDirectories
|
||||
, takeFileName
|
||||
, (</>)
|
||||
)
|
||||
import System.IO
|
||||
(
|
||||
IOMode
|
||||
, Handle
|
||||
, openFile
|
||||
)
|
||||
import System.IO.Error
|
||||
(
|
||||
ioeGetErrorType
|
||||
, isDoesNotExistErrorType
|
||||
)
|
||||
import System.IO.Unsafe
|
||||
(
|
||||
unsafeInterleaveIO
|
||||
)
|
||||
import System.Locale
|
||||
(
|
||||
defaultTimeLocale
|
||||
, rfc822DateFormat
|
||||
)
|
||||
import System.Posix.Types
|
||||
(
|
||||
DeviceID
|
||||
, EpochTime
|
||||
, FileID
|
||||
, FileMode
|
||||
, FileOffset
|
||||
, GroupID
|
||||
, LinkCount
|
||||
, UserID
|
||||
)
|
||||
|
||||
import qualified System.Posix.Files as PF
|
||||
import qualified System.Posix.Directory as PFD
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
--[ BASE TYPES ]--
|
||||
----------------------------
|
||||
|
||||
|
||||
-- |Represents a file. The `anchor` field is the path
|
||||
-- to that file without the filename.
|
||||
data AnchoredFile a =
|
||||
(:/) { anchor :: Path Abs, file :: File a }
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
-- |The String in the name field is always a file name, never a full path.
|
||||
-- The free type variable is used in the File/Dir constructor and can hold
|
||||
-- Handles, Strings representing a file's contents or anything else you can
|
||||
-- think of. We catch any IO errors in the Failed constructor. an Exception
|
||||
-- can be converted to a String with 'show'.
|
||||
data File a =
|
||||
Failed {
|
||||
name :: Path Fn
|
||||
, err :: IOException
|
||||
}
|
||||
| Dir {
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
| RegFile {
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
-- TODO: add raw symlink dest (not normalized) to SymLink?
|
||||
| SymLink {
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
, sdest :: AnchoredFile a -- ^ symlink madness,
|
||||
-- we need to know where it points to
|
||||
, rawdest :: FilePath
|
||||
}
|
||||
| BlockDev {
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
| CharDev {
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
| NamedPipe {
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
| Socket {
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
-- |All possible file information we could ever need.
|
||||
data FileInfo = FileInfo {
|
||||
deviceID :: DeviceID
|
||||
, fileID :: FileID
|
||||
, fileMode :: FileMode
|
||||
, linkCount :: LinkCount
|
||||
, fileOwner :: UserID
|
||||
, fileGroup :: GroupID
|
||||
, specialDeviceID :: DeviceID
|
||||
, fileSize :: FileOffset
|
||||
, accessTime :: EpochTime
|
||||
, modificationTime :: EpochTime
|
||||
, statusChangeTime :: EpochTime
|
||||
, accessTimeHiRes :: POSIXTime
|
||||
, modificationTimeHiRes :: POSIXTime
|
||||
, statusChangeTimeHiRes :: POSIXTime
|
||||
} deriving (Show, Eq, Ord)
|
||||
|
||||
|
||||
|
||||
|
||||
------------------------------------
|
||||
--[ ViewPatterns/PatternSynonyms ]--
|
||||
------------------------------------
|
||||
|
||||
|
||||
-- |Converts a viewpattern like function written for `File` to one
|
||||
-- for `AnchoredFile`.
|
||||
convertViewP :: (File FileInfo -> (Bool, File FileInfo))
|
||||
-> AnchoredFile FileInfo
|
||||
-> (Bool, AnchoredFile FileInfo)
|
||||
convertViewP f af@(bp :/ constr) =
|
||||
let (b, file) = f constr
|
||||
in (b, bp :/ file)
|
||||
|
||||
|
||||
|
||||
---- Filetypes ----
|
||||
|
||||
|
||||
safileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
safileLike f = convertViewP sfileLike f
|
||||
|
||||
|
||||
sfileLike :: File FileInfo -> (Bool, File FileInfo)
|
||||
sfileLike f@RegFile{} = (True, f)
|
||||
sfileLike f@BlockDev{} = (True, f)
|
||||
sfileLike f@CharDev{} = (True, f)
|
||||
sfileLike f@NamedPipe{} = (True, f)
|
||||
sfileLike f@Socket{} = (True, f)
|
||||
sfileLike f = fileLikeSym f
|
||||
|
||||
|
||||
afileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
afileLike f@(bp :/ constr) = convertViewP fileLike f
|
||||
|
||||
|
||||
fileLike :: File FileInfo -> (Bool, File FileInfo)
|
||||
fileLike f@RegFile {} = (True, f)
|
||||
fileLike f@BlockDev{} = (True, f)
|
||||
fileLike f@CharDev{} = (True, f)
|
||||
fileLike f@NamedPipe{} = (True, f)
|
||||
fileLike f@Socket{} = (True, f)
|
||||
fileLike f = (False, f)
|
||||
|
||||
|
||||
sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
sadir f = convertViewP sdir f
|
||||
|
||||
|
||||
sdir :: File FileInfo -> (Bool, File FileInfo)
|
||||
sdir f@SymLink{ sdest = (_ :/ s@SymLink{} )}
|
||||
-- we have to follow a chain of symlinks here, but
|
||||
-- return only the very first level
|
||||
-- TODO: this is probably obsolete now
|
||||
= case (sdir s) of
|
||||
(True, _) -> (True, f)
|
||||
_ -> (False, f)
|
||||
sdir f@SymLink{ sdest = (_ :/ Dir {} )}
|
||||
= (True, f)
|
||||
sdir f@Dir{} = (True, f)
|
||||
sdir f = (False, f)
|
||||
|
||||
|
||||
-- |Matches on any non-directory kind of files, excluding symlinks.
|
||||
pattern AFileLike f <- (afileLike -> (True, f))
|
||||
-- |Like `AFileLike`, except on File.
|
||||
pattern FileLike f <- (fileLike -> (True, f))
|
||||
|
||||
-- |Matches a list of directories or symlinks pointing to directories.
|
||||
pattern DirList fs <- (\fs -> (and . fmap (fst . sadir) $ fs, fs)
|
||||
-> (True, fs))
|
||||
|
||||
-- |Matches a list of any non-directory kind of files or symlinks
|
||||
-- pointing to such.
|
||||
pattern FileLikeList fs <- (\fs -> (and
|
||||
. fmap (fst . safileLike)
|
||||
$ fs, fs) -> (True, fs))
|
||||
|
||||
|
||||
---- Filenames ----
|
||||
|
||||
invalidFileName :: Path Fn -> (Bool, Path Fn)
|
||||
invalidFileName p@(Path "") = (True, p)
|
||||
invalidFileName p@(Path ".") = (True, p)
|
||||
invalidFileName p@(Path "..") = (True, p)
|
||||
invalidFileName p@(Path fn) = (elem pathSeparator fn, p)
|
||||
|
||||
|
||||
-- |Matches on invalid filesnames, such as ".", ".." and anything
|
||||
-- that contains a path separator.
|
||||
pattern InvFN <- (invalidFileName -> (True,_))
|
||||
-- |Opposite of `InvFN`.
|
||||
pattern ValFN f <- (invalidFileName -> (False, f))
|
||||
|
||||
-- |Like `InvFN`, but for AnchoredFile.
|
||||
pattern AFileInvFN <- (fst . invalidFileName . name . file -> True)
|
||||
-- |Like `InvFN`, but for File.
|
||||
pattern FileInvFN <- (fst . invalidFileName . name -> True)
|
||||
|
||||
|
||||
---- Symlinks ----
|
||||
|
||||
abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
abrokenSymlink f = convertViewP brokenSymlink f
|
||||
|
||||
|
||||
brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
|
||||
brokenSymlink f = (isBrokenSymlink f, f)
|
||||
|
||||
|
||||
afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
afileLikeSym f = convertViewP fileLikeSym f
|
||||
|
||||
|
||||
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
|
||||
fileLikeSym f@SymLink{ sdest = (_ :/ s@SymLink{} )}
|
||||
= case (fileLikeSym s) of
|
||||
(True, _) -> (True, f)
|
||||
_ -> (False, f)
|
||||
fileLikeSym f@SymLink{ sdest = (_ :/ RegFile {} )} = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = (_ :/ BlockDev {} )} = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = (_ :/ CharDev {} )} = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = (_ :/ NamedPipe {} )} = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = (_ :/ Socket {} )} = (True, f)
|
||||
fileLikeSym f = (False, f)
|
||||
|
||||
|
||||
adirSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
adirSym f = convertViewP dirSym f
|
||||
|
||||
|
||||
dirSym :: File FileInfo -> (Bool, File FileInfo)
|
||||
dirSym f@SymLink{ sdest = (_ :/ s@SymLink{} )}
|
||||
= case (dirSym s) of
|
||||
(True, _) -> (True, f)
|
||||
_ -> (False, f)
|
||||
dirSym f@SymLink{ sdest = (_ :/ Dir {} )} = (True, f)
|
||||
dirSym f = (False, f)
|
||||
|
||||
|
||||
-- |Matches on symlinks pointing to file-like files only.
|
||||
pattern AFileLikeSym f <- (afileLikeSym -> (True, f))
|
||||
-- |Like `AFileLikeSym`, except on File.
|
||||
pattern FileLikeSym f <- (fileLikeSym -> (True, f))
|
||||
|
||||
-- |Matches on broken symbolic links.
|
||||
pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f))
|
||||
-- |Like `ABrokenSymlink`, except on File.
|
||||
pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
|
||||
|
||||
-- |Matches on directories or symlinks pointing to directories.
|
||||
-- If the symlink is pointing to a symlink pointing to a directory, then
|
||||
-- it will return True, but also return the first element in the symlink-
|
||||
-- chain, not the last.
|
||||
pattern ADirOrSym f <- (sadir -> (True, f))
|
||||
-- |Like `ADirOrSym`, except on File.
|
||||
pattern DirOrSym f <- (sdir -> (True, f))
|
||||
|
||||
-- |Matches on symlinks pointing to directories only.
|
||||
pattern ADirSym f <- (adirSym -> (True, f))
|
||||
-- |Like `ADirSym`, except on File.
|
||||
pattern DirSym f <- (dirSym -> (True, f))
|
||||
|
||||
-- |Matches on any non-directory kind of files or symlinks pointing to
|
||||
-- such.
|
||||
-- If the symlink is pointing to a symlink pointing to such a file, then
|
||||
-- it will return True, but also return the first element in the symlink-
|
||||
-- chain, not the last.
|
||||
pattern AFileLikeOrSym f <- (safileLike -> (True, f))
|
||||
-- |Like `AFileLikeOrSym`, except on File.
|
||||
pattern FileLikeOrSym f <- (sfileLike -> (True, f))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ INSTANCES ]--
|
||||
-----------------
|
||||
|
||||
|
||||
-- | First compare constructors: Failed < Dir < File...
|
||||
-- Then compare `name`...
|
||||
-- Then compare free variable parameter of `File` constructors
|
||||
instance Ord (File FileInfo) where
|
||||
compare (RegFile n a) (RegFile n' a') =
|
||||
case compare n n' of
|
||||
EQ -> compare a a'
|
||||
el -> el
|
||||
compare (Dir n b) (Dir n' b') =
|
||||
case compare n n' of
|
||||
EQ -> compare b b'
|
||||
el -> el
|
||||
-- after comparing above we can hand off to shape ord function:
|
||||
compare d d' = comparingConstr d d'
|
||||
|
||||
|
||||
-- |First compare anchor, then compare File.
|
||||
instance Ord (AnchoredFile FileInfo) where
|
||||
compare (bp1 :/ a) (bp2 :/ b) =
|
||||
case compare bp1 bp2 of
|
||||
EQ -> compare a b
|
||||
el -> el
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
--[ HIGH LEVEL FUNCTIONS ]--
|
||||
----------------------------
|
||||
|
||||
|
||||
-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
|
||||
-- variables via the given function.
|
||||
readWith :: (Path Abs -> IO a) -- ^ function that fills the free
|
||||
-- a variable
|
||||
-> Path Abs -- ^ Path to read
|
||||
-> IO (AnchoredFile a)
|
||||
readWith ff p = do
|
||||
let fn = P.basename p
|
||||
bd = P.dirname p
|
||||
p' = P.toFilePath p
|
||||
bd' <- P.canonicalizePath bd -- TODO: this will cause a dialog to pop up on error
|
||||
handleDT bd' fn $ do
|
||||
fs <- PF.getSymbolicLinkStatus p'
|
||||
fv <- ff p
|
||||
file <- constructFile fs fv bd' fn
|
||||
return (bd' :/ file)
|
||||
where
|
||||
constructFile fs fv bd' fn'
|
||||
| PF.isSymbolicLink fs = do
|
||||
-- symlink madness, we need to make sure we save the correct
|
||||
-- AnchoredFile
|
||||
let fp = bd' P.</> fn'
|
||||
x <- PF.readSymbolicLink (P.fromAbs fp)
|
||||
resolvedSyml <- handleDT bd' fn' $ do
|
||||
-- watch out, we call </> from 'filepath' here, but it is safe
|
||||
-- TODO: could it happen that too many '..' lead
|
||||
-- to something like '/' after normalization?
|
||||
let sfp = if isAbsolute x then x else (P.fromAbs bd') </> x
|
||||
sf <- PF.getFileStatus sfp -- important to break infinite symbolic
|
||||
-- link cycle
|
||||
rsfp <- P.realPath sfp
|
||||
readWith ff =<< P.parseAbs rsfp
|
||||
return $ SymLink fn' fv resolvedSyml x
|
||||
| PF.isDirectory fs = return $ Dir fn' fv
|
||||
| PF.isRegularFile fs = return $ RegFile fn' fv
|
||||
| PF.isBlockDevice fs = return $ BlockDev fn' fv
|
||||
| PF.isCharacterDevice fs = return $ CharDev fn' fv
|
||||
| PF.isNamedPipe fs = return $ NamedPipe fn' fv
|
||||
| PF.isSocket fs = return $ Socket fn' fv
|
||||
| otherwise = return $ Failed fn' (userError
|
||||
"Unknown filetype!")
|
||||
|
||||
|
||||
-- |Reads a file Path into an AnchoredFile.
|
||||
readFile :: (Path Abs -> IO a) -> Path Abs -> IO (AnchoredFile a)
|
||||
readFile ff fp = readWith ff fp
|
||||
|
||||
readFileWithFileInfo :: Path Abs -> IO (AnchoredFile FileInfo)
|
||||
readFileWithFileInfo = HSFM.FileSystem.FileType.readFile getFileInfo
|
||||
|
||||
-- |Build a list of AnchoredFile, given the path to a directory, filling
|
||||
-- the free variables via `getFileInfo`. This includes the "." and ".."
|
||||
-- directories.
|
||||
readDirectoryContents :: Path Abs -> IO [AnchoredFile FileInfo]
|
||||
readDirectoryContents fp = readDirectoryContentsWith getAllDirsFiles getFileInfo fp
|
||||
|
||||
|
||||
-- |Build a list of AnchoredFile, given the path to a directory, filling
|
||||
-- the free variables via `getFileInfo`. This excludes the "." and ".."
|
||||
-- directories.
|
||||
readDirectoryContents' :: Path Abs -> IO [AnchoredFile FileInfo]
|
||||
readDirectoryContents' fp = readDirectoryContentsWith getDirsFiles getFileInfo fp
|
||||
|
||||
|
||||
-- |Same as readDirectoryContents but allows us to, for example, use
|
||||
-- ByteString.readFile to return a tree of ByteStrings.
|
||||
readDirectoryContentsWith :: (Path Abs -> IO [Path Fn])
|
||||
-> (Path Abs -> IO a)
|
||||
-> Path Abs
|
||||
-> IO [AnchoredFile a]
|
||||
readDirectoryContentsWith getfiles ff p = do
|
||||
files <- getfiles p
|
||||
fcs <- mapM (\x -> HSFM.FileSystem.FileType.readFile ff $ p P.</> x) files
|
||||
return $ removeNonexistent fcs
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ UTILITIES ]--
|
||||
-----------------
|
||||
|
||||
|
||||
|
||||
---- HANDLING FAILURES ----
|
||||
|
||||
|
||||
-- | True if any Failed constructors in the tree
|
||||
anyFailed :: [File a] -> Bool
|
||||
anyFailed = not . successful
|
||||
|
||||
-- | True if there are no Failed constructors in the tree
|
||||
successful :: [File a] -> Bool
|
||||
successful = null . failures
|
||||
|
||||
|
||||
-- | returns true if argument is a `Failed` constructor:
|
||||
failed :: File a -> Bool
|
||||
failed (Failed _ _) = True
|
||||
failed _ = False
|
||||
|
||||
|
||||
-- | returns a list of 'Failed' constructors only:
|
||||
failures :: [File a] -> [File a]
|
||||
failures = filter failed
|
||||
|
||||
|
||||
|
||||
---- ORDERING AND EQUALITY ----
|
||||
|
||||
|
||||
-- HELPER: a non-recursive comparison
|
||||
comparingConstr :: File FileInfo -> File FileInfo -> Ordering
|
||||
comparingConstr (Failed _ _) (DirOrSym _) = LT
|
||||
comparingConstr (Failed _ _) (FileLikeOrSym _) = LT
|
||||
comparingConstr (FileLikeOrSym _) (Failed _ _) = GT
|
||||
comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT
|
||||
comparingConstr (DirOrSym _) (Failed _ _) = GT
|
||||
comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT
|
||||
-- else compare on the names of constructors that are the same, without
|
||||
-- looking at the contents of Dir constructors:
|
||||
comparingConstr t t' = compare (name t) (name t')
|
||||
|
||||
|
||||
|
||||
|
||||
---- OTHER ----
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--[ HELPERS ]--
|
||||
---------------
|
||||
|
||||
|
||||
---- CONSTRUCTOR IDENTIFIERS ----
|
||||
|
||||
isFileC :: File a -> Bool
|
||||
isFileC (RegFile _ _) = True
|
||||
isFileC _ = False
|
||||
|
||||
|
||||
isDirC :: File a -> Bool
|
||||
isDirC (Dir _ _) = True
|
||||
isDirC _ = False
|
||||
|
||||
|
||||
isSymC :: File a -> Bool
|
||||
isSymC (SymLink _ _ _ _) = True
|
||||
isSymC _ = False
|
||||
|
||||
|
||||
isBlockC :: File a -> Bool
|
||||
isBlockC (BlockDev _ _) = True
|
||||
isBlockC _ = False
|
||||
|
||||
|
||||
isCharC :: File a -> Bool
|
||||
isCharC (CharDev _ _) = True
|
||||
isCharC _ = False
|
||||
|
||||
|
||||
|
||||
isNamedC :: File a -> Bool
|
||||
isNamedC (NamedPipe _ _) = True
|
||||
isNamedC _ = False
|
||||
|
||||
|
||||
isSocketC :: File a -> Bool
|
||||
isSocketC (Socket _ _) = True
|
||||
isSocketC _ = False
|
||||
|
||||
|
||||
|
||||
|
||||
---- IO HELPERS: ----
|
||||
|
||||
|
||||
-- |Go up one directory in the filesystem hierarchy.
|
||||
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
|
||||
goUp af@(Path "" :/ _) = return af
|
||||
goUp (bp :/ _) = HSFM.FileSystem.FileType.readFile getFileInfo bp
|
||||
|
||||
|
||||
-- |Go up one directory in the filesystem hierarchy.
|
||||
goUp' :: Path Abs -> IO (AnchoredFile FileInfo)
|
||||
goUp' fp = HSFM.FileSystem.FileType.readFile getFileInfo $ P.dirname fp
|
||||
|
||||
|
||||
-- |Get the contents of a directory.
|
||||
getContents :: AnchoredFile FileInfo
|
||||
-> IO [AnchoredFile FileInfo]
|
||||
getContents (ADirOrSym af) = readDirectoryContents (fullPath af)
|
||||
getContents _ = return []
|
||||
|
||||
|
||||
getDirsFiles' :: (FilePath -> [FilePath] -> [FilePath])
|
||||
-> Path Abs
|
||||
-> IO [Path Fn]
|
||||
getDirsFiles' filterf fp = do
|
||||
dirstream <- PFD.openDirStream . P.toFilePath $ fp
|
||||
let mdirs :: [FilePath] -> IO [FilePath]
|
||||
mdirs dirs = do
|
||||
-- make sure we close the directory stream in case of errors
|
||||
dir <- onException (PFD.readDirStream dirstream)
|
||||
(PFD.closeDirStream dirstream)
|
||||
if dir == ""
|
||||
then return dirs
|
||||
else mdirs (dir `filterf` dirs)
|
||||
dirs <- mdirs []
|
||||
PFD.closeDirStream dirstream
|
||||
return $ catMaybes (fmap P.parseFn dirs)
|
||||
|
||||
|
||||
-- |Get all files of a given directory and return them as a List.
|
||||
-- This includes "." and "..".
|
||||
getAllDirsFiles :: Path Abs -> IO [Path Fn]
|
||||
getAllDirsFiles = getDirsFiles' (:)
|
||||
|
||||
|
||||
-- |Get all files of a given directory and return them as a List.
|
||||
-- This excludes "." and "..".
|
||||
getDirsFiles :: Path Abs -> IO [Path Fn]
|
||||
getDirsFiles = getDirsFiles' insert
|
||||
where
|
||||
insert dir dirs = case dir of
|
||||
"." -> dirs
|
||||
".." -> dirs
|
||||
_ -> dir : dirs
|
||||
|
||||
|
||||
-- |Gets all file information.
|
||||
getFileInfo :: Path Abs -> IO FileInfo
|
||||
getFileInfo fp = do
|
||||
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
|
||||
return $ FileInfo
|
||||
(PF.deviceID fs)
|
||||
(PF.fileID fs)
|
||||
(PF.fileMode fs)
|
||||
(PF.linkCount fs)
|
||||
(PF.fileOwner fs)
|
||||
(PF.fileGroup fs)
|
||||
(PF.specialDeviceID fs)
|
||||
(PF.fileSize fs)
|
||||
(PF.accessTime fs)
|
||||
(PF.modificationTime fs)
|
||||
(PF.statusChangeTime fs)
|
||||
(PF.accessTimeHiRes fs)
|
||||
(PF.modificationTimeHiRes fs)
|
||||
(PF.statusChangeTimeHiRes fs)
|
||||
|
||||
|
||||
|
||||
---- FAILURE HELPERS: ----
|
||||
|
||||
|
||||
-- Handles an IO exception by returning a Failed constructor filled with that
|
||||
-- exception.
|
||||
-- TODO: only handle IO exceptions
|
||||
handleDT :: Path Abs
|
||||
-> Path Fn
|
||||
-> IO (AnchoredFile a)
|
||||
-> IO (AnchoredFile a)
|
||||
handleDT bp n
|
||||
= handle (\e -> return $ bp :/ Failed n e)
|
||||
|
||||
|
||||
-- DoesNotExist errors not present at the topmost level could happen if a
|
||||
-- named file or directory is deleted after being listed by
|
||||
-- getDirectoryContents but before we can get it into memory.
|
||||
-- So we filter those errors out because the user should not see errors
|
||||
-- raised by the internal implementation of this module:
|
||||
-- This leaves the error if it exists in the top (user-supplied) level:
|
||||
removeNonexistent :: [AnchoredFile a] -> [AnchoredFile a]
|
||||
removeNonexistent = filter isOkConstructor
|
||||
where
|
||||
isOkConstructor (_ :/ c) = not (failed c) || isOkError c
|
||||
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
|
||||
|
||||
|
||||
---- SYMLINK HELPERS: ----
|
||||
|
||||
|
||||
-- |Checks if a symlink is broken by examining the constructor of the
|
||||
-- symlink destination.
|
||||
--
|
||||
-- When called on a non-symlink, returns False.
|
||||
isBrokenSymlink :: File FileInfo -> Bool
|
||||
isBrokenSymlink af@(SymLink _ _ (_ :/ Failed {}) _) = True
|
||||
isBrokenSymlink _ = False
|
||||
|
||||
|
||||
---- OTHER: ----
|
||||
|
||||
|
||||
-- |Check whether the given file is a hidden file.
|
||||
hiddenFile :: Path Fn -> Bool
|
||||
hiddenFile (Path ".") = False
|
||||
hiddenFile (Path "..") = False
|
||||
hiddenFile (Path fn) = "." `isPrefixOf` fn
|
||||
|
||||
|
||||
-- |Apply a function on the free variable. If there is no free variable
|
||||
-- for the given constructor the value from the `Default` class is used.
|
||||
fromFreeVar :: (Default d) => (a -> d) -> File a -> d
|
||||
fromFreeVar f df = maybeD f $ getFreeVar df
|
||||
|
||||
|
||||
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
|
||||
getFreeVar :: File a -> Maybe a
|
||||
getFreeVar (Dir _ d) = Just d
|
||||
getFreeVar (RegFile _ d) = Just d
|
||||
getFreeVar (SymLink _ d _ _) = Just d
|
||||
getFreeVar (BlockDev _ d) = Just d
|
||||
getFreeVar (CharDev _ d) = Just d
|
||||
getFreeVar (NamedPipe _ d) = Just d
|
||||
getFreeVar (Socket _ d) = Just d
|
||||
getFreeVar _ = Nothing
|
||||
|
||||
|
||||
-- |Get the full path of the file.
|
||||
fullPath :: AnchoredFile a -> Path Abs
|
||||
fullPath (bp :/ f) = bp P.</> name f
|
||||
|
||||
|
||||
-- |Get the full path of the file, converted to a `FilePath`.
|
||||
fullPathS :: AnchoredFile a -> FilePath
|
||||
fullPathS = P.fromAbs . fullPath
|
||||
|
||||
|
||||
-- |Pack the modification time into a string.
|
||||
packModTime :: File FileInfo
|
||||
-> String
|
||||
packModTime =
|
||||
fromFreeVar
|
||||
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
|
||||
|
||||
|
||||
-- |Pack the permissions into a string, similar to what "ls -l" does.
|
||||
packPermissions :: File FileInfo
|
||||
-> String
|
||||
packPermissions dt = fromFreeVar (pStr . fileMode) dt
|
||||
where
|
||||
pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
|
||||
where
|
||||
typeModeStr = case dt of
|
||||
Dir {} -> "d"
|
||||
RegFile {} -> "-"
|
||||
SymLink {} -> "l"
|
||||
BlockDev {} -> "b"
|
||||
CharDev {} -> "c"
|
||||
NamedPipe {} -> "p"
|
||||
Socket {} -> "s"
|
||||
ownerModeStr = hasFmStr PF.ownerReadMode "r"
|
||||
++ hasFmStr PF.ownerWriteMode "w"
|
||||
++ hasFmStr PF.ownerExecuteMode "x"
|
||||
groupModeStr = hasFmStr PF.groupReadMode "r"
|
||||
++ hasFmStr PF.groupWriteMode "w"
|
||||
++ hasFmStr PF.groupExecuteMode "x"
|
||||
otherModeStr = hasFmStr PF.otherReadMode "r"
|
||||
++ hasFmStr PF.otherWriteMode "w"
|
||||
++ hasFmStr PF.otherExecuteMode "x"
|
||||
hasFmStr fm str
|
||||
| hasFM fm = str
|
||||
| otherwise = "-"
|
||||
hasFM fm = ffm `PF.intersectFileModes` fm == fm
|
||||
Reference in New Issue
Block a user