LIB/GTK: refactor File base type

We have now ditched AnchoredFile and just use File with Path Abs
in the path field.

This is useful since we now:
* don't allow "." or ".." as filenames anymore
* normalise paths in our path parsers and reject paths with ".."

This also allows us to know that filepaths are always valid. In addition
the 'basename' function from hpath may throw an exception if run
on the root dir "/". This exception is basically uncatched currently,
which is fine, because it's not a selectable directory.
This commit is contained in:
Julian Ospald 2016-04-15 14:23:41 +02:00
parent 3d15a66350
commit bb6c1b3cda
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
8 changed files with 223 additions and 392 deletions

2
3rdparty/hpath vendored

@ -1 +1 @@
Subproject commit c570505297f22fda08248dae66072c9bff9ce607 Subproject commit 577ecf67508839c485df10335583a625fcf88bc4

View File

@ -144,7 +144,7 @@ throwSameFile fp1 fp2 = do
-- canonicalize `dirname fp2` -- canonicalize `dirname fp2`
fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2) fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
(\_ -> fmap P.fromAbs (\_ -> fmap P.fromAbs
$ (P.</> P.basename fp2) $ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2)
<$> (P.canonicalizePath $ P.dirname fp2)) <$> (P.canonicalizePath $ P.dirname fp2))
when (P.equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2') when (P.equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
@ -159,7 +159,8 @@ throwDestinationInSource :: Path Abs -- ^ source dir
-> IO () -> IO ()
throwDestinationInSource source dest = do throwDestinationInSource source dest = do
source' <- P.canonicalizePath source source' <- P.canonicalizePath source
dest' <- (P.</> P.basename dest) <$> (P.canonicalizePath $ P.dirname dest) dest' <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
<$> (P.canonicalizePath $ P.dirname dest)
dids <- forM (P.getAllParents dest') $ \p -> do dids <- forM (P.getAllParents dest') $ \p -> do
fs <- PF.getSymbolicLinkStatus (P.fromAbs p) fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
return (PF.deviceID fs, PF.fileID fs) return (PF.deviceID fs, PF.fileID fs)

View File

@ -171,7 +171,7 @@ data CopyMode = Strict -- ^ fail if the target already exists
-- be returned. Returns `Nothing` on success. -- be returned. Returns `Nothing` on success.
-- --
-- Since file operations can be delayed, this is `Path Abs` based, not -- Since file operations can be delayed, this is `Path Abs` based, not
-- `AnchoredFile` based. This makes sure we don't have stale -- `File` based. This makes sure we don't have stale
-- file information. -- file information.
runFileOp :: FileOperation -> IO (Maybe FileOperation) runFileOp :: FileOperation -> IO (Maybe FileOperation)
runFileOp fo' = runFileOp fo' =
@ -179,7 +179,7 @@ runFileOp fo' =
(FCopy (CC froms to cm)) -> do (FCopy (CC froms to cm)) -> do
froms' <- mapM toAfile froms froms' <- mapM toAfile froms
to' <- toAfile to to' <- toAfile to
when (anyFailed $ file <$> froms') when (anyFailed froms')
(throw . CopyFailed $ "File in copy buffer does not exist anymore!") (throw . CopyFailed $ "File in copy buffer does not exist anymore!")
mapM_ (\x -> easyCopy cm x to') froms' mapM_ (\x -> easyCopy cm x to') froms'
>> return Nothing >> return Nothing
@ -187,7 +187,7 @@ runFileOp fo' =
(FMove (MC froms to cm)) -> do (FMove (MC froms to cm)) -> do
froms' <- mapM toAfile froms froms' <- mapM toAfile froms
to' <- toAfile to to' <- toAfile to
when (anyFailed $ file <$> froms') when (anyFailed froms')
(throw . MoveFailed $ "File in move buffer does not exist anymore!") (throw . MoveFailed $ "File in move buffer does not exist anymore!")
mapM_ (\x -> easyMove cm x to') froms' mapM_ (\x -> easyMove cm x to') froms'
>> return Nothing >> return Nothing
@ -213,21 +213,18 @@ runFileOp fo' =
-- |Copies a directory to the given destination with the specified -- |Copies a directory to the given destination with the specified
-- `DirCopyMode`. Excludes symlinks. -- `DirCopyMode`. Excludes symlinks.
copyDir :: CopyMode copyDir :: CopyMode
-> AnchoredFile a -- ^ source dir -> File a -- ^ source dir
-> AnchoredFile a -- ^ destination dir -> File a -- ^ destination dir
-> Path Fn -- ^ destination dir name -> Path Fn -- ^ destination dir name
-> IO () -> IO ()
copyDir _ AFileInvFN _ _ = throw InvalidFileName
copyDir _ _ AFileInvFN _ = throw InvalidFileName
copyDir _ _ _ InvFN = throw InvalidFileName
copyDir (Rename fn) copyDir (Rename fn)
from@(_ :/ Dir {}) from@Dir{}
to@(_ :/ Dir {}) to@Dir{}
_ _
= copyDir Strict from to fn = copyDir Strict from to fn
-- this branch must never get `Rename` as CopyMode -- this branch must never get `Rename` as CopyMode
copyDir cm from@(_ :/ Dir {}) copyDir cm from@Dir{}
to@(_ :/ Dir {}) to@Dir{}
fn fn
= do = do
let fromp = fullPath from let fromp = fullPath from
@ -240,23 +237,25 @@ copyDir cm from@(_ :/ Dir {})
throwCantOpenDirectory top throwCantOpenDirectory top
go cm from to fn go cm from to fn
where where
go :: CopyMode -> AnchoredFile a -> AnchoredFile a -> Path Fn -> IO () go :: CopyMode -> File a -> File a -> Path Fn -> IO ()
go cm' from'@(_ :/ Dir {}) go cm' from'@Dir{}
to'@(_ :/ Dir {}) to'@Dir{}
fn' = do fn' = do
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fullPathS from') fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fullPathS from')
createDestdir (fullPath to' P.</> fn') fmode' createDestdir (fullPath to' P.</> fn') fmode'
destdir <- readFileUnsafe (\_ -> return undefined) destdir <- readFile (\_ -> return undefined)
(fullPath to' P.</> fn') (fullPath to' P.</> fn')
contents <- readDirectoryContentsUnsafe contents <- readDirectoryContents
getDirsFiles (\_ -> return undefined) (fullPath from') (\_ -> return undefined) (fullPath from')
for_ contents $ \f -> for_ contents $ \f ->
case f of case f of
(_ :/ SymLink {}) -> recreateSymlink cm' f destdir (name . file $ f) SymLink{} -> recreateSymlink cm' f destdir
(_ :/ Dir {}) -> go cm' f destdir (name . file $ f) =<< (P.basename . path $ f)
(_ :/ RegFile {}) -> unsafeCopyFile Replace f destdir Dir{} -> go cm' f destdir
(name . file $ f) =<< (P.basename . path $ f)
RegFile{} -> unsafeCopyFile Replace f destdir
=<< (P.basename . path $ f)
_ -> return () _ -> return ()
where where
createDestdir destdir fmode' = createDestdir destdir fmode' =
@ -271,7 +270,7 @@ copyDir cm from@(_ :/ Dir {})
Replace -> do Replace -> do
whenM (doesDirectoryExist destdir) whenM (doesDirectoryExist destdir)
(deleteDirRecursive =<< (deleteDirRecursive =<<
readFileUnsafe readFile
(\_ -> return undefined) destdir) (\_ -> return undefined) destdir)
createDirectory destdir' fmode' createDirectory destdir' fmode'
_ -> throw $ InvalidOperation "Internal error, wrong CopyMode!" _ -> throw $ InvalidOperation "Internal error, wrong CopyMode!"
@ -281,17 +280,14 @@ copyDir _ _ _ _ = throw $ InvalidOperation "wrong input type"
-- |Recreate a symlink. -- |Recreate a symlink.
recreateSymlink :: CopyMode recreateSymlink :: CopyMode
-> AnchoredFile a -- ^ the old symlink file -> File a -- ^ the old symlink file
-> AnchoredFile a -- ^ destination dir of the -> File a -- ^ destination dir of the
-- new symlink file -- new symlink file
-> Path Fn -- ^ destination file name -> Path Fn -- ^ destination file name
-> IO () -> IO ()
recreateSymlink _ AFileInvFN _ _ = throw InvalidFileName recreateSymlink (Rename pn) symf@SymLink{} symdest@Dir{} _
recreateSymlink _ _ AFileInvFN _ = throw InvalidFileName
recreateSymlink _ _ _ InvFN = throw InvalidFileName
recreateSymlink (Rename pn) symf@(_ :/ SymLink {}) symdest@(_ :/ Dir {}) _
= recreateSymlink Strict symf symdest pn = recreateSymlink Strict symf symdest pn
recreateSymlink cm symf@(_ :/ SymLink {}) symdest@(_ :/ Dir {}) fn recreateSymlink cm symf@SymLink{} symdest@Dir{} fn
= do = do
throwCantOpenDirectory $ fullPath symdest throwCantOpenDirectory $ fullPath symdest
sympoint <- readSymbolicLink (fullPathS symf) sympoint <- readSymbolicLink (fullPathS symf)
@ -303,8 +299,8 @@ recreateSymlink cm symf@(_ :/ SymLink {}) symdest@(_ :/ Dir {}) fn
createSymbolicLink sympoint (P.fromAbs symname) createSymbolicLink sympoint (P.fromAbs symname)
where where
delOld symname = do delOld symname = do
f <- readFileUnsafe (\_ -> return undefined) symname f <- readFile (\_ -> return undefined) symname
unless (failed . file $ f) unless (failed f)
(easyDelete f) (easyDelete f)
recreateSymlink _ _ _ _ = throw $ InvalidOperation "wrong input type" recreateSymlink _ _ _ _ = throw $ InvalidOperation "wrong input type"
@ -312,16 +308,13 @@ recreateSymlink _ _ _ _ = throw $ InvalidOperation "wrong input type"
-- |Copies the given regular file to the given dir with the given filename. -- |Copies the given regular file to the given dir with the given filename.
-- Excludes symlinks. -- Excludes symlinks.
copyFile :: CopyMode copyFile :: CopyMode
-> AnchoredFile a -- ^ source file -> File a -- ^ source file
-> AnchoredFile a -- ^ destination dir -> File a -- ^ destination dir
-> Path Fn -- ^ destination file name -> Path Fn -- ^ destination file name
-> IO () -> IO ()
copyFile _ AFileInvFN _ _ = throw InvalidFileName copyFile (Rename pn) from@RegFile{} to@Dir{} _
copyFile _ _ AFileInvFN _ = throw InvalidFileName
copyFile _ _ _ InvFN = throw InvalidFileName
copyFile (Rename pn) from@(_ :/ RegFile {}) to@(_ :/ Dir {}) _
= copyFile Strict from to pn = copyFile Strict from to pn
copyFile cm from@(_ :/ RegFile {}) to@(_ :/ Dir {}) fn copyFile cm from@RegFile{} to@Dir{} fn
= do = do
let to' = fullPath to P.</> fn let to' = fullPath to P.</> fn
throwCantOpenDirectory $ fullPath to throwCantOpenDirectory $ fullPath to
@ -336,16 +329,13 @@ copyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
-- It's also used for cases where we don't need/want sanity checks -- It's also used for cases where we don't need/want sanity checks
-- and need the extra bit of performance. -- and need the extra bit of performance.
unsafeCopyFile :: CopyMode unsafeCopyFile :: CopyMode
-> AnchoredFile a -- ^ source file -> File a -- ^ source file
-> AnchoredFile a -- ^ destination dir -> File a -- ^ destination dir
-> Path Fn -- ^ destination file name -> Path Fn -- ^ destination file name
-> IO () -> IO ()
unsafeCopyFile _ AFileInvFN _ _ = throw InvalidFileName unsafeCopyFile (Rename pn) from@RegFile{} to@Dir{} _
unsafeCopyFile _ _ AFileInvFN _ = throw InvalidFileName
unsafeCopyFile _ _ _ InvFN = throw InvalidFileName
unsafeCopyFile (Rename pn) from@(_ :/ RegFile {}) to@(_ :/ Dir {}) _
= copyFile Strict from to pn = copyFile Strict from to pn
unsafeCopyFile cm from@(_ :/ RegFile {}) to@(_ :/ Dir {}) fn unsafeCopyFile cm from@RegFile{} to@Dir{} fn
= do = do
let to' = fullPath to P.</> fn let to' = fullPath to P.</> fn
case cm of case cm of
@ -402,18 +392,18 @@ unsafeCopyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
-- |Copies a regular file, directory or symlink. In case of a symlink, -- |Copies a regular file, directory or symlink. In case of a symlink,
-- it is just recreated, even if it points to a directory. -- it is just recreated, even if it points to a directory.
easyCopy :: CopyMode easyCopy :: CopyMode
-> AnchoredFile a -> File a
-> AnchoredFile a -> File a
-> IO () -> IO ()
easyCopy cm from@(_ :/ SymLink{}) easyCopy cm from@SymLink{}
to@(_ :/ Dir{}) to@Dir{}
= recreateSymlink cm from to (name . file $ from) = recreateSymlink cm from to =<< (P.basename . path $ from)
easyCopy cm from@(_ :/ RegFile{}) easyCopy cm from@RegFile{}
to@(_ :/ Dir{}) to@Dir{}
= copyFile cm from to (name . file $ from) = copyFile cm from to =<< (P.basename . path $ from)
easyCopy cm from@(_ :/ Dir{}) easyCopy cm from@Dir{}
to@(_ :/ Dir{}) to@Dir{}
= copyDir cm from to (name . file $ from) = copyDir cm from to =<< (P.basename . path $ from)
easyCopy _ _ _ = throw $ InvalidOperation "wrong input type" easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
@ -426,47 +416,43 @@ easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
-- |Deletes a symlink, which can either point to a file or directory. -- |Deletes a symlink, which can either point to a file or directory.
deleteSymlink :: AnchoredFile a -> IO () deleteSymlink :: File a -> IO ()
deleteSymlink AFileInvFN = throw InvalidFileName deleteSymlink f@SymLink{}
deleteSymlink f@(_ :/ SymLink {})
= removeLink (P.toFilePath . fullPath $ f) = removeLink (P.toFilePath . fullPath $ f)
deleteSymlink _ = throw $ InvalidOperation "wrong input type" deleteSymlink _ = throw $ InvalidOperation "wrong input type"
-- |Deletes the given regular file, never symlinks. -- |Deletes the given regular file, never symlinks.
deleteFile :: AnchoredFile a -> IO () deleteFile :: File a -> IO ()
deleteFile AFileInvFN = throw InvalidFileName deleteFile f@RegFile{}
deleteFile f@(_ :/ RegFile {})
= removeLink (P.toFilePath . fullPath $ f) = removeLink (P.toFilePath . fullPath $ f)
deleteFile _ = throw $ InvalidOperation "wrong input type" deleteFile _ = throw $ InvalidOperation "wrong input type"
-- |Deletes the given directory, never symlinks. -- |Deletes the given directory, never symlinks.
deleteDir :: AnchoredFile a -> IO () deleteDir :: File a -> IO ()
deleteDir AFileInvFN = throw InvalidFileName deleteDir f@Dir{}
deleteDir f@(_ :/ Dir {})
= removeDirectory (P.toFilePath . fullPath $ f) = removeDirectory (P.toFilePath . fullPath $ f)
deleteDir _ = throw $ InvalidOperation "wrong input type" deleteDir _ = throw $ InvalidOperation "wrong input type"
-- |Deletes the given directory recursively. -- |Deletes the given directory recursively.
deleteDirRecursive :: AnchoredFile a -> IO () deleteDirRecursive :: File a -> IO ()
deleteDirRecursive AFileInvFN = throw InvalidFileName deleteDirRecursive f'@Dir{} = do
deleteDirRecursive f'@(_ :/ Dir {}) = do
let fp = fullPath f' let fp = fullPath f'
throwCantOpenDirectory fp throwCantOpenDirectory fp
go f' go f'
where where
go :: AnchoredFile a -> IO () go :: File a -> IO ()
go f@(_ :/ Dir {}) = do go f@Dir{} = do
let fp = fullPath f let fp = fullPath f
files <- readDirectoryContentsUnsafe getDirsFiles files <- readDirectoryContents
(\_ -> return undefined) fp (\_ -> return undefined) fp
for_ files $ \file -> for_ files $ \file ->
case file of case file of
(_ :/ SymLink {}) -> deleteSymlink file SymLink{} -> deleteSymlink file
(_ :/ Dir {}) -> go file Dir{} -> go file
(_ :/ RegFile {}) -> removeLink (P.toFilePath . fullPath $ file) RegFile{} -> removeLink (P.toFilePath . fullPath $ file)
_ -> throw $ FileDoesExist _ -> throw $ FileDoesExist
(P.toFilePath . fullPath (P.toFilePath . fullPath
$ file) $ file)
@ -478,11 +464,11 @@ deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"
-- |Deletes a file, directory or symlink, whatever it may be. -- |Deletes a file, directory or symlink, whatever it may be.
-- In case of directory, performs recursive deletion. In case of -- In case of directory, performs recursive deletion. In case of
-- a symlink, the symlink file is deleted. -- a symlink, the symlink file is deleted.
easyDelete :: AnchoredFile a -> IO () easyDelete :: File a -> IO ()
easyDelete f@(_ :/ SymLink {}) = deleteSymlink f easyDelete f@SymLink{} = deleteSymlink f
easyDelete f@(_ :/ RegFile {}) easyDelete f@RegFile{}
= deleteFile f = deleteFile f
easyDelete f@(_ :/ Dir {}) easyDelete f@Dir{}
= deleteDirRecursive f = deleteDirRecursive f
easyDelete _ = throw $ InvalidOperation "wrong input type" easyDelete _ = throw $ InvalidOperation "wrong input type"
@ -496,21 +482,19 @@ easyDelete _ = throw $ InvalidOperation "wrong input type"
-- |Opens a file appropriately by invoking xdg-open. The file type -- |Opens a file appropriately by invoking xdg-open. The file type
-- is not checked. -- is not checked.
openFile :: AnchoredFile a openFile :: File a
-> IO ProcessID -> IO ProcessID
openFile AFileInvFN = throw InvalidFileName
openFile f = openFile f =
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fullPathS f] Nothing SPP.forkProcess $ SPP.executeFile "xdg-open" True [fullPathS f] Nothing
-- |Executes a program with the given arguments. -- |Executes a program with the given arguments.
executeFile :: AnchoredFile a -- ^ program executeFile :: File a -- ^ program
-> [ByteString] -- ^ arguments -> [ByteString] -- ^ arguments
-> IO ProcessID -> IO ProcessID
executeFile AFileInvFN _ = throw InvalidFileName executeFile prog@RegFile{} args
executeFile prog@(_ :/ RegFile {}) args
= SPP.forkProcess $ SPP.executeFile (fullPathS prog) True args Nothing = SPP.forkProcess $ SPP.executeFile (fullPathS prog) True args Nothing
executeFile prog@(_ :/ SymLink { sdest = (_ :/ RegFile {}) }) args executeFile prog@SymLink{ sdest = RegFile{} } args
= SPP.forkProcess $ SPP.executeFile (fullPathS prog) True args Nothing = SPP.forkProcess $ SPP.executeFile (fullPathS prog) True args Nothing
executeFile _ _ = throw $ InvalidOperation "wrong input type" executeFile _ _ = throw $ InvalidOperation "wrong input type"
@ -523,10 +507,8 @@ executeFile _ _ = throw $ InvalidOperation "wrong input type"
-- |Create an empty regular file at the given directory with the given filename. -- |Create an empty regular file at the given directory with the given filename.
createFile :: AnchoredFile FileInfo -> Path Fn -> IO () createFile :: File FileInfo -> Path Fn -> IO ()
createFile AFileInvFN _ = throw InvalidFileName createFile (DirOrSym td) fn = do
createFile _ InvFN = throw InvalidFileName
createFile (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td P.</> fn let fullp = fullPath td P.</> fn
throwFileDoesExist fullp throwFileDoesExist fullp
fd <- SPI.createFile (P.fromAbs fullp) newFilePerms fd <- SPI.createFile (P.fromAbs fullp) newFilePerms
@ -535,10 +517,8 @@ createFile _ _ = throw $ InvalidOperation "wrong input type"
-- |Create an empty directory at the given directory with the given filename. -- |Create an empty directory at the given directory with the given filename.
createDir :: AnchoredFile FileInfo -> Path Fn -> IO () createDir :: File FileInfo -> Path Fn -> IO ()
createDir AFileInvFN _ = throw InvalidFileName createDir (DirOrSym td) fn = do
createDir _ InvFN = throw InvalidFileName
createDir (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td P.</> fn let fullp = fullPath td P.</> fn
throwDirDoesExist fullp throwDirDoesExist fullp
createDirectory (P.fromAbs fullp) newFilePerms createDirectory (P.fromAbs fullp) newFilePerms
@ -553,29 +533,24 @@ createDir _ _ = throw $ InvalidOperation "wrong input type"
-- |Rename a given file with the provided filename. -- |Rename a given file with the provided filename.
renameFile :: AnchoredFile a -> Path Fn -> IO () renameFile :: File a -> Path Fn -> IO ()
renameFile AFileInvFN _ = throw InvalidFileName renameFile af fn = do
renameFile _ InvFN = throw InvalidFileName
renameFile af (ValFN fn) = do
let fromf = fullPath af let fromf = fullPath af
tof = anchor af P.</> fn tof = (P.dirname . path $ af) P.</> fn
throwFileDoesExist tof throwFileDoesExist tof
throwSameFile fromf tof throwSameFile fromf tof
rename (P.fromAbs fromf) (P.fromAbs tof) rename (P.fromAbs fromf) (P.fromAbs tof)
renameFile _ _ = throw $ InvalidOperation "wrong input type"
-- |Move a given file to the given target directory. -- |Move a given file to the given target directory.
moveFile :: CopyMode moveFile :: CopyMode
-> AnchoredFile a -- ^ file to move -> File a -- ^ file to move
-> AnchoredFile a -- ^ base target directory -> File a -- ^ base target directory
-> Path Fn -- ^ target file name -> Path Fn -- ^ target file name
-> IO () -> IO ()
moveFile _ AFileInvFN _ _ = throw InvalidFileName moveFile (Rename pn) from to@Dir{} _ =
moveFile _ _ AFileInvFN _ = throw InvalidFileName
moveFile (Rename pn) from to@(_ :/ Dir {}) _ =
moveFile Strict from to pn moveFile Strict from to pn
moveFile cm from to@(_ :/ Dir {}) fn = do moveFile cm from to@Dir{} fn = do
let from' = fullPath from let from' = fullPath from
froms' = fullPathS from froms' = fullPathS from
to' = fullPath to P.</> fn to' = fullPath to P.</> fn
@ -591,17 +566,17 @@ moveFile cm from to@(_ :/ Dir {}) fn = do
easyDelete from easyDelete from
where where
delOld fp = do delOld fp = do
to' <- readFileUnsafe (\_ -> return undefined) fp to' <- readFile (\_ -> return undefined) fp
unless (failed . file $ to') (easyDelete to') unless (failed to') (easyDelete to')
moveFile _ _ _ _ = throw $ InvalidOperation "wrong input type" moveFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
-- |Like `moveFile` except it uses the filename of the source as target. -- |Like `moveFile` except it uses the filename of the source as target.
easyMove :: CopyMode easyMove :: CopyMode
-> AnchoredFile a -- ^ file to move -> File a -- ^ file to move
-> AnchoredFile a -- ^ base target directory -> File a -- ^ base target directory
-> IO () -> IO ()
easyMove cm from to = moveFile cm from to (name . file $ from) easyMove cm from to = moveFile cm from to =<< (P.basename . path $ from)

View File

@ -16,7 +16,6 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides data types for representing directories/files -- |This module provides data types for representing directories/files
@ -49,8 +48,6 @@ import HPath
( (
Abs Abs
, Path , Path
, Fn
, pattern Path
) )
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.Errors import HSFM.FileSystem.Errors
@ -85,52 +82,45 @@ import System.Posix.Types
---------------------------- ----------------------------
-- |Represents a file. The `anchor` field is the path -- |The String in the path field is always a full 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 -- 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 -- 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 -- think of. We catch any IO errors in the Failed constructor. an Exception
-- can be converted to a String with 'show'. -- can be converted to a String with 'show'.
data File a = data File a =
Failed { Failed {
name :: Path Fn path :: Path Abs
, err :: IOError , err :: IOError
} }
| Dir { | Dir {
name :: Path Fn path :: Path Abs
, fvar :: a , fvar :: a
} }
| RegFile { | RegFile {
name :: Path Fn path :: Path Abs
, fvar :: a , fvar :: a
} }
| SymLink { | SymLink {
name :: Path Fn path :: Path Abs
, fvar :: a , fvar :: a
, sdest :: AnchoredFile a -- ^ symlink madness, , sdest :: File a -- ^ symlink madness,
-- we need to know where it points to -- we need to know where it points to
, rawdest :: ByteString , rawdest :: ByteString
} }
| BlockDev { | BlockDev {
name :: Path Fn path :: Path Abs
, fvar :: a , fvar :: a
} }
| CharDev { | CharDev {
name :: Path Fn path :: Path Abs
, fvar :: a , fvar :: a
} }
| NamedPipe { | NamedPipe {
name :: Path Fn path :: Path Abs
, fvar :: a , fvar :: a
} }
| Socket { | Socket {
name :: Path Fn path :: Path Abs
, fvar :: a , fvar :: a
} deriving (Show, Eq) } deriving (Show, Eq)
@ -161,24 +151,11 @@ data FileInfo = FileInfo {
------------------------------------ ------------------------------------
-- |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 (bp :/ constr) =
let (b, file) = f constr
in (b, bp :/ file)
---- Filetypes ---- ---- Filetypes ----
safileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
safileLike f = convertViewP sfileLike f
sfileLike :: File FileInfo -> (Bool, File FileInfo) sfileLike :: File FileInfo -> (Bool, File FileInfo)
sfileLike f@RegFile{} = (True, f) sfileLike f@RegFile{} = (True, f)
sfileLike f@BlockDev{} = (True, f) sfileLike f@BlockDev{} = (True, f)
@ -188,10 +165,6 @@ sfileLike f@Socket{} = (True, f)
sfileLike f = fileLikeSym f sfileLike f = fileLikeSym f
afileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
afileLike f = convertViewP fileLike f
fileLike :: File FileInfo -> (Bool, File FileInfo) fileLike :: File FileInfo -> (Bool, File FileInfo)
fileLike f@RegFile {} = (True, f) fileLike f@RegFile {} = (True, f)
fileLike f@BlockDev{} = (True, f) fileLike f@BlockDev{} = (True, f)
@ -201,122 +174,78 @@ fileLike f@Socket{} = (True, f)
fileLike f = (False, f) fileLike f = (False, f)
sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
sadir f = convertViewP sdir f
sdir :: File FileInfo -> (Bool, File FileInfo) sdir :: File FileInfo -> (Bool, File FileInfo)
sdir f@SymLink{ sdest = (_ :/ s@SymLink{} )} sdir f@SymLink{ sdest = (s@SymLink{} )}
-- we have to follow a chain of symlinks here, but -- we have to follow a chain of symlinks here, but
-- return only the very first level -- return only the very first level
-- TODO: this is probably obsolete now -- TODO: this is probably obsolete now
= case sdir s of = case sdir s of
(True, _) -> (True, f) (True, _) -> (True, f)
_ -> (False, f) _ -> (False, f)
sdir f@SymLink{ sdest = (_ :/ Dir {} )} sdir f@SymLink{ sdest = Dir{} }
= (True, f) = (True, f)
sdir f@Dir{} = (True, f) sdir f@Dir{} = (True, f)
sdir f = (False, f) sdir f = (False, f)
-- |Matches on any non-directory kind of files, excluding symlinks. -- |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)) pattern FileLike f <- (fileLike -> (True, f))
-- |Matches a list of directories or symlinks pointing to directories. -- |Matches a list of directories or symlinks pointing to directories.
pattern DirList fs <- (\fs -> (and . fmap (fst . sadir) $ fs, fs) pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs)
-> (True, fs)) -> (True, fs))
-- |Matches a list of any non-directory kind of files or symlinks -- |Matches a list of any non-directory kind of files or symlinks
-- pointing to such. -- pointing to such.
pattern FileLikeList fs <- (\fs -> (and pattern FileLikeList fs <- (\fs -> (and
. fmap (fst . safileLike) . fmap (fst . sfileLike)
$ fs, fs) -> (True, fs)) $ 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 = (B.elem P.pathSeparator (P.fromRel p), 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 ---- ---- Symlinks ----
abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
abrokenSymlink f = convertViewP brokenSymlink f
brokenSymlink :: File FileInfo -> (Bool, File FileInfo) brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
brokenSymlink f = (isBrokenSymlink f, f) brokenSymlink f = (isBrokenSymlink f, f)
afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
afileLikeSym f = convertViewP fileLikeSym f
fileLikeSym :: File FileInfo -> (Bool, File FileInfo) fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
fileLikeSym f@SymLink{ sdest = (_ :/ s@SymLink{} )} fileLikeSym f@SymLink{ sdest = s@SymLink{} }
= case fileLikeSym s of = case fileLikeSym s of
(True, _) -> (True, f) (True, _) -> (True, f)
_ -> (False, f) _ -> (False, f)
fileLikeSym f@SymLink{ sdest = (_ :/ RegFile {} )} = (True, f) fileLikeSym f@SymLink{ sdest = RegFile{} } = (True, f)
fileLikeSym f@SymLink{ sdest = (_ :/ BlockDev {} )} = (True, f) fileLikeSym f@SymLink{ sdest = BlockDev{} } = (True, f)
fileLikeSym f@SymLink{ sdest = (_ :/ CharDev {} )} = (True, f) fileLikeSym f@SymLink{ sdest = CharDev{} } = (True, f)
fileLikeSym f@SymLink{ sdest = (_ :/ NamedPipe {} )} = (True, f) fileLikeSym f@SymLink{ sdest = NamedPipe{} } = (True, f)
fileLikeSym f@SymLink{ sdest = (_ :/ Socket {} )} = (True, f) fileLikeSym f@SymLink{ sdest = Socket{} } = (True, f)
fileLikeSym f = (False, f) fileLikeSym f = (False, f)
adirSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
adirSym f = convertViewP dirSym f
dirSym :: File FileInfo -> (Bool, File FileInfo) dirSym :: File FileInfo -> (Bool, File FileInfo)
dirSym f@SymLink{ sdest = (_ :/ s@SymLink{} )} dirSym f@SymLink{ sdest = s@SymLink{} }
= case dirSym s of = case dirSym s of
(True, _) -> (True, f) (True, _) -> (True, f)
_ -> (False, f) _ -> (False, f)
dirSym f@SymLink{ sdest = (_ :/ Dir {} )} = (True, f) dirSym f@SymLink{ sdest = Dir{} } = (True, f)
dirSym f = (False, f) dirSym f = (False, f)
-- |Matches on symlinks pointing to file-like files only. -- |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)) pattern FileLikeSym f <- (fileLikeSym -> (True, f))
-- |Matches on broken symbolic links. -- |Matches on broken symbolic links.
pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f))
-- |Like `ABrokenSymlink`, except on File.
pattern BrokenSymlink f <- (brokenSymlink -> (True, f)) pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
-- |Matches on directories or symlinks pointing to directories. -- |Matches on directories or symlinks pointing to directories.
-- If the symlink is pointing to a symlink pointing to a directory, then -- 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- -- it will return True, but also return the first element in the symlink-
-- chain, not the last. -- chain, not the last.
pattern ADirOrSym f <- (sadir -> (True, f))
-- |Like `ADirOrSym`, except on File.
pattern DirOrSym f <- (sdir -> (True, f)) pattern DirOrSym f <- (sdir -> (True, f))
-- |Matches on symlinks pointing to directories only. -- |Matches on symlinks pointing to directories only.
pattern ADirSym f <- (adirSym -> (True, f))
-- |Like `ADirSym`, except on File.
pattern DirSym f <- (dirSym -> (True, f)) pattern DirSym f <- (dirSym -> (True, f))
-- |Matches on any non-directory kind of files or symlinks pointing to -- |Matches on any non-directory kind of files or symlinks pointing to
@ -324,8 +253,6 @@ pattern DirSym f <- (dirSym -> (True, f))
-- If the symlink is pointing to a symlink pointing to such a file, then -- 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- -- it will return True, but also return the first element in the symlink-
-- chain, not the last. -- chain, not the last.
pattern AFileLikeOrSym f <- (safileLike -> (True, f))
-- |Like `AFileLikeOrSym`, except on File.
pattern FileLikeOrSym f <- (sfileLike -> (True, f)) pattern FileLikeOrSym f <- (sfileLike -> (True, f))
@ -353,14 +280,6 @@ instance Ord (File FileInfo) where
compare d d' = comparingConstr d d' 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
@ -369,128 +288,70 @@ instance Ord (AnchoredFile FileInfo) where
---------------------------- ----------------------------
-- |Reads a file or directory Path into an `AnchoredFile`, filling the free -- |Reads a file or directory Path into an `AnchoredFile`, filling the free
-- variables via the given function. -- variables via the given function.
-- The dirname of the given path will be canonicalized using `realpath`, so the readFile :: (Path Abs -> IO a)
-- anchor of `AnchoredFile` is always canonicalized. -> Path Abs
-- -> IO (File a)
-- Exceptions: when `canonicalizePath` fails, throws IOError readFile ff p =
readFile :: (Path Abs -> IO a) -- ^ function that fills the free handleDT p $ do
-- a variable fs <- PF.getSymbolicLinkStatus (P.toFilePath p)
-> Path Abs -- ^ Path to read
-> IO (AnchoredFile a)
readFile ff p = do
cdp <- P.canonicalizePath (P.dirname p)
readFileUnsafe ff (cdp P.</> P.basename p)
-- |A variant of `readFile` which does not use `realpath` at all.
-- Suitable for cases where we know the paths are safe/correct
-- and need the extra bit of performance.
readFileUnsafe :: (Path Abs -> IO a)
-> Path Abs
-> IO (AnchoredFile a)
readFileUnsafe ff p = do
let fn = P.basename p
bd = P.dirname p
p' = P.toFilePath p
handleDT bd fn $ do
fs <- PF.getSymbolicLinkStatus p'
fv <- ff p fv <- ff p
file <- constructFile fs fv bd fn constructFile fs fv p
return (bd :/ file)
where where
constructFile fs fv bd' fn' constructFile fs fv p'
| PF.isSymbolicLink fs = do | PF.isSymbolicLink fs = do
-- symlink madness, we need to make sure we save the correct -- symlink madness, we need to make sure we save the correct
-- AnchoredFile -- AnchoredFile
let fp = bd' P.</> fn' x <- PF.readSymbolicLink (P.fromAbs p')
x <- PF.readSymbolicLink (P.fromAbs fp) resolvedSyml <- handleDT p' $ do
resolvedSyml <- handleDT bd' fn' $ do
-- watch out, we call </> from 'filepath' here, but it is safe -- watch out, we call </> from 'filepath' here, but it is safe
-- TODO: could it happen that too many '..' lead -- TODO: could it happen that too many '..' lead
-- to something like '/' after normalization? -- to something like '/' after normalization?
let sfp = P.fromAbs bd' `P.combine` x let sfp = (P.fromAbs . P.dirname $ p') `P.combine` x
rsfp <- P.realPath sfp rsfp <- P.realPath sfp
readFile ff =<< P.parseAbs rsfp readFile ff =<< P.parseAbs rsfp
return $ SymLink fn' fv resolvedSyml x return $ SymLink p' fv resolvedSyml x
| PF.isDirectory fs = return $ Dir fn' fv | PF.isDirectory fs = return $ Dir p' fv
| PF.isRegularFile fs = return $ RegFile fn' fv | PF.isRegularFile fs = return $ RegFile p' fv
| PF.isBlockDevice fs = return $ BlockDev fn' fv | PF.isBlockDevice fs = return $ BlockDev p' fv
| PF.isCharacterDevice fs = return $ CharDev fn' fv | PF.isCharacterDevice fs = return $ CharDev p' fv
| PF.isNamedPipe fs = return $ NamedPipe fn' fv | PF.isNamedPipe fs = return $ NamedPipe p' fv
| PF.isSocket fs = return $ Socket fn' fv | PF.isSocket fs = return $ Socket p' fv
| otherwise = return $ Failed fn' (userError | otherwise = return $ Failed p' (userError
"Unknown filetype!") "Unknown filetype!")
-- |Reads a file via `readFile` and fills the free variable via `getFileInfo`.
readFileWithFileInfo :: Path Abs -> IO (AnchoredFile FileInfo)
readFileWithFileInfo = readFile getFileInfo
-- |Same as readDirectoryContents but allows us to, for example, use -- |Get the contents of a given directory and return them as a list
-- ByteString.readFile to return a tree of ByteStrings. -- of `AnchoredFile`.
readDirectoryContents :: (Path Abs -> IO [Path Fn]) readDirectoryContents :: (Path Abs -> IO a) -- ^ fills free a variable
-> (Path Abs -> IO a) -> Path Abs -- ^ path to read
-> Path Abs -> IO [File a]
-> IO [AnchoredFile a] readDirectoryContents ff p = do
readDirectoryContents getfiles ff p = do files <- getDirsFiles p
files <- getfiles p fcs <- mapM (readFile ff) files
fcs <- mapM (\x -> readFile ff $ p P.</> x) files
return $ removeNonexistent fcs return $ removeNonexistent fcs
-- |A variant of `readDirectoryContents` which uses `readFileUnsafe`. -- |A variant of `readDirectoryContents` where the third argument
-- Suitable for cases where we know the paths are safe/correct -- is a `File`. If a non-directory is passed returns an empty list.
-- and need the extra bit of performance. getContents :: (Path Abs -> IO a)
readDirectoryContentsUnsafe :: (Path Abs -> IO [Path Fn]) -> File FileInfo
-> (Path Abs -> IO a) -> IO [File a]
-> Path Abs getContents ff (DirOrSym af)
-> IO [AnchoredFile a] = readDirectoryContents ff (fullPath af)
readDirectoryContentsUnsafe getfiles ff p = do getContents _ _ = return []
files <- getfiles p
fcs <- mapM (\x -> readFileUnsafe ff $ p P.</> x) files
return $ removeNonexistent fcs
-- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This includes the "." and ".."
-- directories.
readDirectoryContentsWithFileInfo :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectoryContentsWithFileInfo fp
= readDirectoryContents 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.
readDirectoryContentsWithFileInfo' :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectoryContentsWithFileInfo' fp
= readDirectoryContents getDirsFiles getFileInfo fp
-- |Get the contents of a directory, including "." and "..".
getContents :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo]
getContents (ADirOrSym af) = readDirectoryContentsWithFileInfo (fullPath af)
getContents _ = return []
-- |Get the contents of a directory, including "." and "..".
getContents' :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo]
getContents' (ADirOrSym af) = readDirectoryContentsWithFileInfo' (fullPath af)
getContents' _ = return []
-- |Go up one directory in the filesystem hierarchy. -- |Go up one directory in the filesystem hierarchy.
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo) goUp :: File FileInfo -> IO (File FileInfo)
goUp af@(Path "" :/ _) = return af goUp file = readFile getFileInfo (P.dirname . path $ file)
goUp (bp :/ _) = readFile getFileInfo bp
-- |Go up one directory in the filesystem hierarchy. -- |Go up one directory in the filesystem hierarchy.
goUp' :: Path Abs -> IO (AnchoredFile FileInfo) goUp' :: Path Abs -> IO (File FileInfo)
goUp' fp = readFile getFileInfo $ P.dirname fp goUp' fp = readFile getFileInfo $ P.dirname fp
@ -539,7 +400,7 @@ comparingConstr (DirOrSym _) (Failed _ _) = GT
comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT
-- else compare on the names of constructors that are the same, without -- else compare on the names of constructors that are the same, without
-- looking at the contents of Dir constructors: -- looking at the contents of Dir constructors:
comparingConstr t t' = compare (name t) (name t') comparingConstr t t' = compare (path t) (path t')
@ -594,48 +455,28 @@ isSocketC _ = False
---- IO HELPERS: ---- ---- IO HELPERS: ----
-- |Gets all filenames of the given directory. -- |Gets all filenames of the given directory. This excludes "." and "..".
-- The first argument is a filter function that allows to exclude getDirsFiles :: Path Abs -- ^ dir to read
-- filenames from the result. -> IO [Path Abs]
getDirsFiles' :: (Path Fn -> [Path Fn] -> [Path Fn]) -- ^ filter function getDirsFiles fp =
-> Path Abs -- ^ dir to read
-> IO [Path Fn]
getDirsFiles' filterf fp =
rethrowErrnoAs [eACCES] (Can'tOpenDirectory . P.fromAbs $ fp) rethrowErrnoAs [eACCES] (Can'tOpenDirectory . P.fromAbs $ fp)
$ bracket (PFD.openDirStream . P.toFilePath $ fp) $ bracket (PFD.openDirStream . P.toFilePath $ fp)
PFD.closeDirStream PFD.closeDirStream
$ \dirstream -> $ \dirstream ->
let mdirs :: [Path Fn] -> IO [Path Fn] let mdirs :: [Path Abs] -> IO [Path Abs]
mdirs dirs = do mdirs dirs = do
-- make sure we close the directory stream in case of errors -- make sure we close the directory stream in case of errors
-- TODO: more explicit error handling? -- TODO: more explicit error handling?
-- both the parsing and readin the stream can fail! -- both the parsing and readin the stream can fail!
dir <- PFD.readDirStream dirstream dir <- PFD.readDirStream dirstream
case dir of if B.null dir
"" -> return dirs then return dirs
_ -> do else mdirs $ maybe dirs
pdir <- P.parseFn dir (\x -> fp P.</> x : dirs)
mdirs $ pdir `filterf` dirs (P.parseFn dir)
in mdirs [] in mdirs []
-- |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
(Path ".") -> dirs
(Path "..") -> dirs
_ -> dir : dirs
-- |Gets all file information. -- |Gets all file information.
getFileInfo :: Path Abs -> IO FileInfo getFileInfo :: Path Abs -> IO FileInfo
getFileInfo fp = do getFileInfo fp = do
@ -664,11 +505,10 @@ getFileInfo fp = do
-- Handles an IO exception by returning a Failed constructor filled with that -- Handles an IO exception by returning a Failed constructor filled with that
-- exception. Does not handle FmIOExceptions. -- exception. Does not handle FmIOExceptions.
handleDT :: Path Abs handleDT :: Path Abs
-> Path Fn -> IO (File a)
-> IO (AnchoredFile a) -> IO (File a)
-> IO (AnchoredFile a) handleDT p
handleDT bp n = handleIOError $ \e -> return $ Failed p e
= handleIOError $ \e -> return $ bp :/ Failed n e
-- DoesNotExist errors not present at the topmost level could happen if a -- DoesNotExist errors not present at the topmost level could happen if a
@ -677,10 +517,10 @@ handleDT bp n
-- So we filter those errors out because the user should not see errors -- So we filter those errors out because the user should not see errors
-- raised by the internal implementation of this module: -- raised by the internal implementation of this module:
-- This leaves the error if it exists in the top (user-supplied) level: -- This leaves the error if it exists in the top (user-supplied) level:
removeNonexistent :: [AnchoredFile a] -> [AnchoredFile a] removeNonexistent :: [File a] -> [File a]
removeNonexistent = filter isOkConstructor removeNonexistent = filter isOkConstructor
where where
isOkConstructor (_ :/ c) = not (failed c) || isOkError c isOkConstructor c = not (failed c) || isOkError c
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
@ -692,7 +532,7 @@ removeNonexistent = filter isOkConstructor
-- --
-- When called on a non-symlink, returns False. -- When called on a non-symlink, returns False.
isBrokenSymlink :: File FileInfo -> Bool isBrokenSymlink :: File FileInfo -> Bool
isBrokenSymlink (SymLink _ _ (_ :/ Failed {}) _) = True isBrokenSymlink (SymLink _ _ Failed{} _) = True
isBrokenSymlink _ = False isBrokenSymlink _ = False
@ -718,12 +558,12 @@ getFreeVar _ = Nothing
-- |Get the full path of the file. -- |Get the full path of the file.
fullPath :: AnchoredFile a -> Path Abs fullPath :: File a -> Path Abs
fullPath (bp :/ f) = bp P.</> name f fullPath f = path f
-- |Get the full path of the file, converted to a `FilePath`. -- |Get the full path of the file, converted to a `FilePath`.
fullPathS :: AnchoredFile a -> ByteString fullPathS :: File a -> ByteString
fullPathS = P.fromAbs . fullPath fullPathS = P.fromAbs . fullPath

View File

@ -58,6 +58,7 @@ import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView import HSFM.GUI.Gtk.MyView
import HSFM.GUI.Gtk.Utils import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO import HSFM.Utils.IO
import Prelude hiding(readFile)
import System.Glib.UTFString import System.Glib.UTFString
( (
glibToString glibToString
@ -237,8 +238,8 @@ urlGoTo mygui myview = withErrorDialog $ do
open :: [Item] -> MyGUI -> MyView -> IO () open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $ open [item] mygui myview = withErrorDialog $
case item of case item of
ADirOrSym r -> do DirOrSym r -> do
nv <- HSFM.FileSystem.FileType.readFileWithFileInfo $ fullPath r nv <- readFile getFileInfo $ fullPath r
refreshView' mygui myview nv refreshView' mygui myview nv
r -> r ->
void $ openFile r void $ openFile r
@ -356,7 +357,8 @@ renameF [item] _ _ = withErrorDialog $ do
for_ pmfn $ \fn -> do for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ P.fpToString (fullPathS item) let cmsg = "Really rename \"" ++ P.fpToString (fullPathS item)
++ "\"" ++ " to \"" ++ "\"" ++ " to \""
++ P.fpToString (P.fromAbs (anchor item P.</> fn)) ++ "\"?" ++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $ withConfirmationDialog cmsg $
HSFM.FileSystem.FileOperations.renameFile item fn HSFM.FileSystem.FileOperations.renameFile item fn
renameF _ _ _ = withErrorDialog renameF _ _ _ = withErrorDialog

View File

@ -91,13 +91,14 @@ data FMSettings = MkFMSettings {
data FMView = FMTreeView TreeView data FMView = FMTreeView TreeView
| FMIconView IconView | FMIconView IconView
type Item = AnchoredFile FileInfo type Item = File FileInfo
-- |This describes the contents of the current vie and is separated from MyGUI, -- |This describes the contents of the current vie and is separated from MyGUI,
-- because we might want to have multiple views. -- because we might want to have multiple views.
data MyView = MkMyView { data MyView = MkMyView {
view :: TVar FMView view :: TVar FMView
, cwd :: MVar Item
, rawModel :: TVar (ListStore Item) , rawModel :: TVar (ListStore Item)
, sortedModel :: TVar (TypedTreeModelSort Item) , sortedModel :: TVar (TypedTreeModelSort Item)
, filteredModel :: TVar (TypedTreeModelFilter Item) , filteredModel :: TVar (TypedTreeModelFilter Item)

View File

@ -46,6 +46,7 @@ import Data.Foldable
import Data.Maybe import Data.Maybe
( (
catMaybes catMaybes
, fromJust
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks) import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
@ -62,6 +63,7 @@ import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Icons import HSFM.GUI.Gtk.Icons
import HSFM.GUI.Gtk.Utils import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO import HSFM.Utils.IO
import Prelude hiding(readFile)
import System.INotify import System.INotify
( (
addWatch addWatch
@ -79,7 +81,9 @@ import System.IO.Error
-- |Constructs the initial MyView object with a few dummy models. -- |Constructs the initial MyView object with a few dummy models.
-- It also initializes the callbacks. -- It also initializes the callbacks.
createMyView :: MyGUI -> IO FMView -> IO MyView createMyView :: MyGUI
-> IO FMView
-> IO MyView
createMyView mygui iofmv = do createMyView mygui iofmv = do
operationBuffer <- newTVarIO None operationBuffer <- newTVarIO None
@ -91,7 +95,7 @@ createMyView mygui iofmv = do
=<< readTVarIO rawModel =<< readTVarIO rawModel
sortedModel <- newTVarIO =<< treeModelSortNewWithModel sortedModel <- newTVarIO =<< treeModelSortNewWithModel
=<< readTVarIO filteredModel =<< readTVarIO filteredModel
cwd <- newEmptyMVar
view' <- iofmv view' <- iofmv
view <- newTVarIO view' view <- newTVarIO view'
@ -194,6 +198,7 @@ createTreeView = do
-- |Re-reads the current directory or the given one and updates the View. -- |Re-reads the current directory or the given one and updates the View.
-- This is more or less a wrapper around `refreshView'`
-- --
-- If the third argument is Nothing, it tries to re-read the current directory. -- If the third argument is Nothing, it tries to re-read the current directory.
-- If that fails, it reads "/" instead. -- If that fails, it reads "/" instead.
@ -208,12 +213,12 @@ refreshView mygui myview mfp =
case mfp of case mfp of
Just fp -> do Just fp -> do
-- readFileWithFileInfo can just outright fail... -- readFileWithFileInfo can just outright fail...
ecdir <- tryIOError (HSFM.FileSystem.FileType.readFileWithFileInfo fp) ecdir <- tryIOError (readFile getFileInfo fp)
case ecdir of case ecdir of
Right cdir -> Right cdir ->
-- ...or return an `AnchordFile` with a Failed constructor, -- ...or return an `AnchordFile` with a Failed constructor,
-- both of which need to be handled here -- both of which need to be handled here
if (failed . file $ cdir) if (failed cdir)
then refreshView mygui myview =<< getAlternativeDir then refreshView mygui myview =<< getAlternativeDir
else refreshView' mygui myview cdir else refreshView' mygui myview cdir
Left _ -> refreshView mygui myview =<< getAlternativeDir Left _ -> refreshView mygui myview =<< getAlternativeDir
@ -221,7 +226,7 @@ refreshView mygui myview mfp =
where where
getAlternativeDir = do getAlternativeDir = do
ecd <- try (getCurrentDir myview) :: IO (Either SomeException ecd <- try (getCurrentDir myview) :: IO (Either SomeException
(AnchoredFile FileInfo)) Item)
case ecd of case ecd of
Right dir -> return (Just $ fullPath dir) Right dir -> return (Just $ fullPath dir)
Left _ -> return (P.parseAbs "/") Left _ -> return (P.parseAbs "/")
@ -233,14 +238,17 @@ refreshView mygui myview mfp =
-- calls `refreshView` with the 3rd argument being Nothing. -- calls `refreshView` with the 3rd argument being Nothing.
refreshView' :: MyGUI refreshView' :: MyGUI
-> MyView -> MyView
-> AnchoredFile FileInfo -> Item
-> IO () -> IO ()
refreshView' mygui myview dt@(ADirOrSym _) = do refreshView' mygui myview dt@(DirOrSym _) = do
newRawModel <- fileListStore dt myview newRawModel <- fileListStore dt myview
writeTVarIO (rawModel myview) newRawModel writeTVarIO (rawModel myview) newRawModel
view' <- readTVarIO $ view myview view' <- readTVarIO $ view myview
_ <- tryTakeMVar (cwd myview)
putMVar (cwd myview) dt
-- get selected items -- get selected items
tps <- getSelectedTreePaths mygui myview tps <- getSelectedTreePaths mygui myview
trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
@ -255,7 +263,7 @@ refreshView' mygui myview dt@(ADirOrSym _) = do
ntps <- mapM treeRowReferenceGetPath trs ntps <- mapM treeRowReferenceGetPath trs
mapM_ (treeSelectionSelectPath tvs) ntps mapM_ (treeSelectionSelectPath tvs) ntps
_ -> return () _ -> return ()
refreshView' mygui myview (_ :/ Failed{}) = refreshView mygui myview Nothing refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
refreshView' _ _ _ = return () refreshView' _ _ _ = return ()
@ -288,7 +296,7 @@ constructView mygui myview = do
view' <- readTVarIO $ view myview view' <- readTVarIO $ view myview
cdirp <- anchor <$> getFirstItem myview cdirp <- path <$> getCurrentDir myview
-- update urlBar -- update urlBar
entrySetText (urlBar mygui) (P.fromAbs cdirp) entrySetText (urlBar mygui) (P.fromAbs cdirp)
@ -300,7 +308,7 @@ constructView mygui myview = do
writeTVarIO (filteredModel myview) filteredModel' writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui) hidden <- showHidden <$> readTVarIO (settings mygui)
item <- (name . file) <$> treeModelGetRow rawModel' iter item <- treeModelGetRow rawModel' iter >>= (P.basename . path)
if hidden if hidden
then return True then return True
else return $ not . P.hiddenFile $ item else return $ not . P.hiddenFile $ item
@ -318,13 +326,13 @@ constructView mygui myview = do
-- set values -- set values
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0) treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . file) dirtreePix
treeModelSetColumn rawModel' (makeColumnIdString 1) treeModelSetColumn rawModel' (makeColumnIdString 1)
(P.fromRel . name . file) (P.toFilePath . fromJust . P.basename . path)
treeModelSetColumn rawModel' (makeColumnIdString 2) treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . file) packModTime
treeModelSetColumn rawModel' (makeColumnIdString 3) treeModelSetColumn rawModel' (makeColumnIdString 3)
(packPermissions . file) packPermissions
-- update model of view -- update model of view
case view' of case view' of

View File

@ -21,6 +21,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
module HSFM.GUI.Gtk.Utils where module HSFM.GUI.Gtk.Utils where
import Control.Concurrent.MVar
(
readMVar
)
import Control.Concurrent.STM import Control.Concurrent.STM
( (
readTVarIO readTVarIO
@ -37,6 +41,7 @@ import Data.Traversable
import Graphics.UI.Gtk import Graphics.UI.Gtk
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import Prelude hiding(getContents)
@ -100,29 +105,28 @@ withItems mygui myview io = do
-- |Create the 'ListStore' of files/directories from the current directory. -- |Create the 'ListStore' of files/directories from the current directory.
-- This is the function which maps the Data.DirTree data structures -- This is the function which maps the Data.DirTree data structures
-- into the GTK+ data structures. -- into the GTK+ data structures.
fileListStore :: AnchoredFile FileInfo -- ^ current dir fileListStore :: Item -- ^ current dir
-> MyView -> MyView
-> IO (ListStore Item) -> IO (ListStore Item)
fileListStore dt _ = do fileListStore dt _ = do
cs <- HSFM.FileSystem.FileType.getContents dt cs <- getContents getFileInfo dt
listStoreNew cs listStoreNew cs
-- |Currently unsafe. This is used to obtain any item (possibly the '.' item) -- |Currently unsafe. This is used to obtain any item, which will
-- and extract the "current working directory" from it. -- fail if there is none.
getFirstItem :: MyView getFirstItem :: MyView
-> IO (AnchoredFile FileInfo) -> IO Item
getFirstItem myview = do getFirstItem myview = do
rawModel' <- readTVarIO $ rawModel myview rawModel' <- readTVarIO $ rawModel myview
iter <- fromJust <$> treeModelGetIterFirst rawModel' iter <- fromJust <$> treeModelGetIterFirst rawModel'
treeModelGetRow rawModel' iter treeModelGetRow rawModel' iter
-- |Currently unsafe. Gets the current directory via `getFirstItem` and -- |Reads the current directory from MyView.
-- `goUp`.
getCurrentDir :: MyView getCurrentDir :: MyView
-> IO (AnchoredFile FileInfo) -> IO Item
getCurrentDir myview = getFirstItem myview >>= goUp getCurrentDir myview = readMVar (cwd myview)