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:
parent
3d15a66350
commit
bb6c1b3cda
|
|
@ -1 +1 @@
|
|||
Subproject commit c570505297f22fda08248dae66072c9bff9ce607
|
||||
Subproject commit 577ecf67508839c485df10335583a625fcf88bc4
|
||||
|
|
@ -144,7 +144,7 @@ throwSameFile fp1 fp2 = do
|
|||
-- canonicalize `dirname fp2`
|
||||
fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
|
||||
(\_ -> fmap P.fromAbs
|
||||
$ (P.</> P.basename fp2)
|
||||
$ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2)
|
||||
<$> (P.canonicalizePath $ P.dirname fp2))
|
||||
when (P.equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
|
||||
|
||||
|
|
@ -159,7 +159,8 @@ throwDestinationInSource :: Path Abs -- ^ source dir
|
|||
-> IO ()
|
||||
throwDestinationInSource source dest = do
|
||||
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
|
||||
fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
|
||||
return (PF.deviceID fs, PF.fileID fs)
|
||||
|
|
|
|||
|
|
@ -171,7 +171,7 @@ data CopyMode = Strict -- ^ fail if the target already exists
|
|||
-- be returned. Returns `Nothing` on success.
|
||||
--
|
||||
-- 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.
|
||||
runFileOp :: FileOperation -> IO (Maybe FileOperation)
|
||||
runFileOp fo' =
|
||||
|
|
@ -179,7 +179,7 @@ runFileOp fo' =
|
|||
(FCopy (CC froms to cm)) -> do
|
||||
froms' <- mapM toAfile froms
|
||||
to' <- toAfile to
|
||||
when (anyFailed $ file <$> froms')
|
||||
when (anyFailed froms')
|
||||
(throw . CopyFailed $ "File in copy buffer does not exist anymore!")
|
||||
mapM_ (\x -> easyCopy cm x to') froms'
|
||||
>> return Nothing
|
||||
|
|
@ -187,7 +187,7 @@ runFileOp fo' =
|
|||
(FMove (MC froms to cm)) -> do
|
||||
froms' <- mapM toAfile froms
|
||||
to' <- toAfile to
|
||||
when (anyFailed $ file <$> froms')
|
||||
when (anyFailed froms')
|
||||
(throw . MoveFailed $ "File in move buffer does not exist anymore!")
|
||||
mapM_ (\x -> easyMove cm x to') froms'
|
||||
>> return Nothing
|
||||
|
|
@ -213,21 +213,18 @@ runFileOp fo' =
|
|||
-- |Copies a directory to the given destination with the specified
|
||||
-- `DirCopyMode`. Excludes symlinks.
|
||||
copyDir :: CopyMode
|
||||
-> AnchoredFile a -- ^ source dir
|
||||
-> AnchoredFile a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination dir name
|
||||
-> File a -- ^ source dir
|
||||
-> File a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination dir name
|
||||
-> IO ()
|
||||
copyDir _ AFileInvFN _ _ = throw InvalidFileName
|
||||
copyDir _ _ AFileInvFN _ = throw InvalidFileName
|
||||
copyDir _ _ _ InvFN = throw InvalidFileName
|
||||
copyDir (Rename fn)
|
||||
from@(_ :/ Dir {})
|
||||
to@(_ :/ Dir {})
|
||||
from@Dir{}
|
||||
to@Dir{}
|
||||
_
|
||||
= copyDir Strict from to fn
|
||||
-- this branch must never get `Rename` as CopyMode
|
||||
copyDir cm from@(_ :/ Dir {})
|
||||
to@(_ :/ Dir {})
|
||||
copyDir cm from@Dir{}
|
||||
to@Dir{}
|
||||
fn
|
||||
= do
|
||||
let fromp = fullPath from
|
||||
|
|
@ -240,23 +237,25 @@ copyDir cm from@(_ :/ Dir {})
|
|||
throwCantOpenDirectory top
|
||||
go cm from to fn
|
||||
where
|
||||
go :: CopyMode -> AnchoredFile a -> AnchoredFile a -> Path Fn -> IO ()
|
||||
go cm' from'@(_ :/ Dir {})
|
||||
to'@(_ :/ Dir {})
|
||||
go :: CopyMode -> File a -> File a -> Path Fn -> IO ()
|
||||
go cm' from'@Dir{}
|
||||
to'@Dir{}
|
||||
fn' = do
|
||||
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fullPathS from')
|
||||
createDestdir (fullPath to' P.</> fn') fmode'
|
||||
destdir <- readFileUnsafe (\_ -> return undefined)
|
||||
destdir <- readFile (\_ -> return undefined)
|
||||
(fullPath to' P.</> fn')
|
||||
contents <- readDirectoryContentsUnsafe
|
||||
getDirsFiles (\_ -> return undefined) (fullPath from')
|
||||
contents <- readDirectoryContents
|
||||
(\_ -> return undefined) (fullPath from')
|
||||
|
||||
for_ contents $ \f ->
|
||||
case f of
|
||||
(_ :/ SymLink {}) -> recreateSymlink cm' f destdir (name . file $ f)
|
||||
(_ :/ Dir {}) -> go cm' f destdir (name . file $ f)
|
||||
(_ :/ RegFile {}) -> unsafeCopyFile Replace f destdir
|
||||
(name . file $ f)
|
||||
SymLink{} -> recreateSymlink cm' f destdir
|
||||
=<< (P.basename . path $ f)
|
||||
Dir{} -> go cm' f destdir
|
||||
=<< (P.basename . path $ f)
|
||||
RegFile{} -> unsafeCopyFile Replace f destdir
|
||||
=<< (P.basename . path $ f)
|
||||
_ -> return ()
|
||||
where
|
||||
createDestdir destdir fmode' =
|
||||
|
|
@ -271,7 +270,7 @@ copyDir cm from@(_ :/ Dir {})
|
|||
Replace -> do
|
||||
whenM (doesDirectoryExist destdir)
|
||||
(deleteDirRecursive =<<
|
||||
readFileUnsafe
|
||||
readFile
|
||||
(\_ -> return undefined) destdir)
|
||||
createDirectory destdir' fmode'
|
||||
_ -> throw $ InvalidOperation "Internal error, wrong CopyMode!"
|
||||
|
|
@ -281,17 +280,14 @@ copyDir _ _ _ _ = throw $ InvalidOperation "wrong input type"
|
|||
|
||||
-- |Recreate a symlink.
|
||||
recreateSymlink :: CopyMode
|
||||
-> AnchoredFile a -- ^ the old symlink file
|
||||
-> AnchoredFile a -- ^ destination dir of the
|
||||
-- new symlink file
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> File a -- ^ the old symlink file
|
||||
-> File a -- ^ destination dir of the
|
||||
-- new symlink file
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> IO ()
|
||||
recreateSymlink _ AFileInvFN _ _ = throw InvalidFileName
|
||||
recreateSymlink _ _ AFileInvFN _ = throw InvalidFileName
|
||||
recreateSymlink _ _ _ InvFN = throw InvalidFileName
|
||||
recreateSymlink (Rename pn) symf@(_ :/ SymLink {}) symdest@(_ :/ Dir {}) _
|
||||
recreateSymlink (Rename pn) symf@SymLink{} symdest@Dir{} _
|
||||
= recreateSymlink Strict symf symdest pn
|
||||
recreateSymlink cm symf@(_ :/ SymLink {}) symdest@(_ :/ Dir {}) fn
|
||||
recreateSymlink cm symf@SymLink{} symdest@Dir{} fn
|
||||
= do
|
||||
throwCantOpenDirectory $ fullPath symdest
|
||||
sympoint <- readSymbolicLink (fullPathS symf)
|
||||
|
|
@ -303,8 +299,8 @@ recreateSymlink cm symf@(_ :/ SymLink {}) symdest@(_ :/ Dir {}) fn
|
|||
createSymbolicLink sympoint (P.fromAbs symname)
|
||||
where
|
||||
delOld symname = do
|
||||
f <- readFileUnsafe (\_ -> return undefined) symname
|
||||
unless (failed . file $ f)
|
||||
f <- readFile (\_ -> return undefined) symname
|
||||
unless (failed f)
|
||||
(easyDelete f)
|
||||
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.
|
||||
-- Excludes symlinks.
|
||||
copyFile :: CopyMode
|
||||
-> AnchoredFile a -- ^ source file
|
||||
-> AnchoredFile a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> File a -- ^ source file
|
||||
-> File a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> IO ()
|
||||
copyFile _ AFileInvFN _ _ = throw InvalidFileName
|
||||
copyFile _ _ AFileInvFN _ = throw InvalidFileName
|
||||
copyFile _ _ _ InvFN = throw InvalidFileName
|
||||
copyFile (Rename pn) from@(_ :/ RegFile {}) to@(_ :/ Dir {}) _
|
||||
copyFile (Rename pn) from@RegFile{} to@Dir{} _
|
||||
= copyFile Strict from to pn
|
||||
copyFile cm from@(_ :/ RegFile {}) to@(_ :/ Dir {}) fn
|
||||
copyFile cm from@RegFile{} to@Dir{} fn
|
||||
= do
|
||||
let to' = fullPath to P.</> fn
|
||||
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
|
||||
-- and need the extra bit of performance.
|
||||
unsafeCopyFile :: CopyMode
|
||||
-> AnchoredFile a -- ^ source file
|
||||
-> AnchoredFile a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> File a -- ^ source file
|
||||
-> File a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> IO ()
|
||||
unsafeCopyFile _ AFileInvFN _ _ = throw InvalidFileName
|
||||
unsafeCopyFile _ _ AFileInvFN _ = throw InvalidFileName
|
||||
unsafeCopyFile _ _ _ InvFN = throw InvalidFileName
|
||||
unsafeCopyFile (Rename pn) from@(_ :/ RegFile {}) to@(_ :/ Dir {}) _
|
||||
unsafeCopyFile (Rename pn) from@RegFile{} to@Dir{} _
|
||||
= copyFile Strict from to pn
|
||||
unsafeCopyFile cm from@(_ :/ RegFile {}) to@(_ :/ Dir {}) fn
|
||||
unsafeCopyFile cm from@RegFile{} to@Dir{} fn
|
||||
= do
|
||||
let to' = fullPath to P.</> fn
|
||||
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,
|
||||
-- it is just recreated, even if it points to a directory.
|
||||
easyCopy :: CopyMode
|
||||
-> AnchoredFile a
|
||||
-> AnchoredFile a
|
||||
-> File a
|
||||
-> File a
|
||||
-> IO ()
|
||||
easyCopy cm from@(_ :/ SymLink{})
|
||||
to@(_ :/ Dir{})
|
||||
= recreateSymlink cm from to (name . file $ from)
|
||||
easyCopy cm from@(_ :/ RegFile{})
|
||||
to@(_ :/ Dir{})
|
||||
= copyFile cm from to (name . file $ from)
|
||||
easyCopy cm from@(_ :/ Dir{})
|
||||
to@(_ :/ Dir{})
|
||||
= copyDir cm from to (name . file $ from)
|
||||
easyCopy cm from@SymLink{}
|
||||
to@Dir{}
|
||||
= recreateSymlink cm from to =<< (P.basename . path $ from)
|
||||
easyCopy cm from@RegFile{}
|
||||
to@Dir{}
|
||||
= copyFile cm from to =<< (P.basename . path $ from)
|
||||
easyCopy cm from@Dir{}
|
||||
to@Dir{}
|
||||
= copyDir cm from to =<< (P.basename . path $ from)
|
||||
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.
|
||||
deleteSymlink :: AnchoredFile a -> IO ()
|
||||
deleteSymlink AFileInvFN = throw InvalidFileName
|
||||
deleteSymlink f@(_ :/ SymLink {})
|
||||
deleteSymlink :: File a -> IO ()
|
||||
deleteSymlink f@SymLink{}
|
||||
= removeLink (P.toFilePath . fullPath $ f)
|
||||
deleteSymlink _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Deletes the given regular file, never symlinks.
|
||||
deleteFile :: AnchoredFile a -> IO ()
|
||||
deleteFile AFileInvFN = throw InvalidFileName
|
||||
deleteFile f@(_ :/ RegFile {})
|
||||
deleteFile :: File a -> IO ()
|
||||
deleteFile f@RegFile{}
|
||||
= removeLink (P.toFilePath . fullPath $ f)
|
||||
deleteFile _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Deletes the given directory, never symlinks.
|
||||
deleteDir :: AnchoredFile a -> IO ()
|
||||
deleteDir AFileInvFN = throw InvalidFileName
|
||||
deleteDir f@(_ :/ Dir {})
|
||||
deleteDir :: File a -> IO ()
|
||||
deleteDir f@Dir{}
|
||||
= removeDirectory (P.toFilePath . fullPath $ f)
|
||||
deleteDir _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Deletes the given directory recursively.
|
||||
deleteDirRecursive :: AnchoredFile a -> IO ()
|
||||
deleteDirRecursive AFileInvFN = throw InvalidFileName
|
||||
deleteDirRecursive f'@(_ :/ Dir {}) = do
|
||||
deleteDirRecursive :: File a -> IO ()
|
||||
deleteDirRecursive f'@Dir{} = do
|
||||
let fp = fullPath f'
|
||||
throwCantOpenDirectory fp
|
||||
go f'
|
||||
where
|
||||
go :: AnchoredFile a -> IO ()
|
||||
go f@(_ :/ Dir {}) = do
|
||||
go :: File a -> IO ()
|
||||
go f@Dir{} = do
|
||||
let fp = fullPath f
|
||||
files <- readDirectoryContentsUnsafe getDirsFiles
|
||||
files <- readDirectoryContents
|
||||
(\_ -> return undefined) fp
|
||||
for_ files $ \file ->
|
||||
case file of
|
||||
(_ :/ SymLink {}) -> deleteSymlink file
|
||||
(_ :/ Dir {}) -> go file
|
||||
(_ :/ RegFile {}) -> removeLink (P.toFilePath . fullPath $ file)
|
||||
SymLink{} -> deleteSymlink file
|
||||
Dir{} -> go file
|
||||
RegFile{} -> removeLink (P.toFilePath . fullPath $ file)
|
||||
_ -> throw $ FileDoesExist
|
||||
(P.toFilePath . fullPath
|
||||
$ file)
|
||||
|
|
@ -478,11 +464,11 @@ 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 a -> IO ()
|
||||
easyDelete f@(_ :/ SymLink {}) = deleteSymlink f
|
||||
easyDelete f@(_ :/ RegFile {})
|
||||
easyDelete :: File a -> IO ()
|
||||
easyDelete f@SymLink{} = deleteSymlink f
|
||||
easyDelete f@RegFile{}
|
||||
= deleteFile f
|
||||
easyDelete f@(_ :/ Dir {})
|
||||
easyDelete f@Dir{}
|
||||
= deleteDirRecursive f
|
||||
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
|
||||
-- is not checked.
|
||||
openFile :: AnchoredFile a
|
||||
openFile :: File a
|
||||
-> IO ProcessID
|
||||
openFile AFileInvFN = throw InvalidFileName
|
||||
openFile f =
|
||||
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fullPathS f] Nothing
|
||||
|
||||
|
||||
-- |Executes a program with the given arguments.
|
||||
executeFile :: AnchoredFile a -- ^ program
|
||||
executeFile :: File a -- ^ program
|
||||
-> [ByteString] -- ^ arguments
|
||||
-> IO ProcessID
|
||||
executeFile AFileInvFN _ = throw InvalidFileName
|
||||
executeFile prog@(_ :/ RegFile {}) args
|
||||
executeFile prog@RegFile{} args
|
||||
= 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
|
||||
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.
|
||||
createFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
|
||||
createFile AFileInvFN _ = throw InvalidFileName
|
||||
createFile _ InvFN = throw InvalidFileName
|
||||
createFile (ADirOrSym td) (ValFN fn) = do
|
||||
createFile :: File FileInfo -> Path Fn -> IO ()
|
||||
createFile (DirOrSym td) fn = do
|
||||
let fullp = fullPath td P.</> fn
|
||||
throwFileDoesExist fullp
|
||||
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.
|
||||
createDir :: AnchoredFile FileInfo -> Path Fn -> IO ()
|
||||
createDir AFileInvFN _ = throw InvalidFileName
|
||||
createDir _ InvFN = throw InvalidFileName
|
||||
createDir (ADirOrSym td) (ValFN fn) = do
|
||||
createDir :: File FileInfo -> Path Fn -> IO ()
|
||||
createDir (DirOrSym td) fn = do
|
||||
let fullp = fullPath td P.</> fn
|
||||
throwDirDoesExist fullp
|
||||
createDirectory (P.fromAbs fullp) newFilePerms
|
||||
|
|
@ -553,29 +533,24 @@ createDir _ _ = throw $ InvalidOperation "wrong input type"
|
|||
|
||||
|
||||
-- |Rename a given file with the provided filename.
|
||||
renameFile :: AnchoredFile a -> Path Fn -> IO ()
|
||||
renameFile AFileInvFN _ = throw InvalidFileName
|
||||
renameFile _ InvFN = throw InvalidFileName
|
||||
renameFile af (ValFN fn) = do
|
||||
renameFile :: File a -> Path Fn -> IO ()
|
||||
renameFile af fn = do
|
||||
let fromf = fullPath af
|
||||
tof = anchor af P.</> fn
|
||||
tof = (P.dirname . path $ af) P.</> fn
|
||||
throwFileDoesExist tof
|
||||
throwSameFile fromf tof
|
||||
rename (P.fromAbs fromf) (P.fromAbs tof)
|
||||
renameFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Move a given file to the given target directory.
|
||||
moveFile :: CopyMode
|
||||
-> AnchoredFile a -- ^ file to move
|
||||
-> AnchoredFile a -- ^ base target directory
|
||||
-> Path Fn -- ^ target file name
|
||||
-> File a -- ^ file to move
|
||||
-> File a -- ^ base target directory
|
||||
-> Path Fn -- ^ target file name
|
||||
-> IO ()
|
||||
moveFile _ AFileInvFN _ _ = throw InvalidFileName
|
||||
moveFile _ _ AFileInvFN _ = throw InvalidFileName
|
||||
moveFile (Rename pn) from to@(_ :/ Dir {}) _ =
|
||||
moveFile (Rename pn) from to@Dir{} _ =
|
||||
moveFile Strict from to pn
|
||||
moveFile cm from to@(_ :/ Dir {}) fn = do
|
||||
moveFile cm from to@Dir{} fn = do
|
||||
let from' = fullPath from
|
||||
froms' = fullPathS from
|
||||
to' = fullPath to P.</> fn
|
||||
|
|
@ -591,17 +566,17 @@ moveFile cm from to@(_ :/ Dir {}) fn = do
|
|||
easyDelete from
|
||||
where
|
||||
delOld fp = do
|
||||
to' <- readFileUnsafe (\_ -> return undefined) fp
|
||||
unless (failed . file $ to') (easyDelete to')
|
||||
to' <- readFile (\_ -> return undefined) fp
|
||||
unless (failed to') (easyDelete to')
|
||||
moveFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Like `moveFile` except it uses the filename of the source as target.
|
||||
easyMove :: CopyMode
|
||||
-> AnchoredFile a -- ^ file to move
|
||||
-> AnchoredFile a -- ^ base target directory
|
||||
-> File a -- ^ file to move
|
||||
-> File a -- ^ base target directory
|
||||
-> IO ()
|
||||
easyMove cm from to = moveFile cm from to (name . file $ from)
|
||||
easyMove cm from to = moveFile cm from to =<< (P.basename . path $ from)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
--}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
-- |This module provides data types for representing directories/files
|
||||
|
|
@ -49,8 +48,6 @@ import HPath
|
|||
(
|
||||
Abs
|
||||
, Path
|
||||
, Fn
|
||||
, pattern Path
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HSFM.FileSystem.Errors
|
||||
|
|
@ -85,52 +82,45 @@ import System.Posix.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 String in the path field is always 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
|
||||
path :: Path Abs
|
||||
, err :: IOError
|
||||
}
|
||||
| Dir {
|
||||
name :: Path Fn
|
||||
path :: Path Abs
|
||||
, fvar :: a
|
||||
}
|
||||
| RegFile {
|
||||
name :: Path Fn
|
||||
path :: Path Abs
|
||||
, fvar :: a
|
||||
}
|
||||
| SymLink {
|
||||
name :: Path Fn
|
||||
path :: Path Abs
|
||||
, fvar :: a
|
||||
, sdest :: AnchoredFile a -- ^ symlink madness,
|
||||
-- we need to know where it points to
|
||||
, sdest :: File a -- ^ symlink madness,
|
||||
-- we need to know where it points to
|
||||
, rawdest :: ByteString
|
||||
}
|
||||
| BlockDev {
|
||||
name :: Path Fn
|
||||
path :: Path Abs
|
||||
, fvar :: a
|
||||
}
|
||||
| CharDev {
|
||||
name :: Path Fn
|
||||
path :: Path Abs
|
||||
, fvar :: a
|
||||
}
|
||||
| NamedPipe {
|
||||
name :: Path Fn
|
||||
path :: Path Abs
|
||||
, fvar :: a
|
||||
}
|
||||
| Socket {
|
||||
name :: Path Fn
|
||||
path :: Path Abs
|
||||
, fvar :: a
|
||||
} 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 ----
|
||||
|
||||
|
||||
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)
|
||||
|
|
@ -188,10 +165,6 @@ sfileLike f@Socket{} = (True, f)
|
|||
sfileLike f = fileLikeSym f
|
||||
|
||||
|
||||
afileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
afileLike f = convertViewP fileLike f
|
||||
|
||||
|
||||
fileLike :: File FileInfo -> (Bool, File FileInfo)
|
||||
fileLike f@RegFile {} = (True, f)
|
||||
fileLike f@BlockDev{} = (True, f)
|
||||
|
|
@ -201,122 +174,78 @@ 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{} )}
|
||||
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 {} )}
|
||||
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)
|
||||
pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ 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)
|
||||
. fmap (fst . sfileLike)
|
||||
$ 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 ----
|
||||
|
||||
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{} )}
|
||||
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
|
||||
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)
|
||||
|
||||
|
||||
dirSym :: File FileInfo -> (Bool, File FileInfo)
|
||||
dirSym f@SymLink{ sdest = (_ :/ s@SymLink{} )}
|
||||
dirSym f@SymLink{ sdest = s@SymLink{} }
|
||||
= case dirSym s of
|
||||
(True, _) -> (True, f)
|
||||
_ -> (False, f)
|
||||
dirSym f@SymLink{ sdest = (_ :/ Dir {} )} = (True, 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
|
||||
|
|
@ -324,8 +253,6 @@ pattern DirSym f <- (dirSym -> (True, f))
|
|||
-- 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))
|
||||
|
||||
|
||||
|
|
@ -353,14 +280,6 @@ instance Ord (File FileInfo) where
|
|||
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
|
||||
-- variables via the given function.
|
||||
-- The dirname of the given path will be canonicalized using `realpath`, so the
|
||||
-- anchor of `AnchoredFile` is always canonicalized.
|
||||
--
|
||||
-- Exceptions: when `canonicalizePath` fails, throws IOError
|
||||
readFile :: (Path Abs -> IO a) -- ^ function that fills the free
|
||||
-- a variable
|
||||
-> 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'
|
||||
readFile :: (Path Abs -> IO a)
|
||||
-> Path Abs
|
||||
-> IO (File a)
|
||||
readFile ff p =
|
||||
handleDT p $ do
|
||||
fs <- PF.getSymbolicLinkStatus (P.toFilePath p)
|
||||
fv <- ff p
|
||||
file <- constructFile fs fv bd fn
|
||||
return (bd :/ file)
|
||||
constructFile fs fv p
|
||||
where
|
||||
constructFile fs fv bd' fn'
|
||||
constructFile fs fv p'
|
||||
| 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
|
||||
x <- PF.readSymbolicLink (P.fromAbs p')
|
||||
resolvedSyml <- handleDT p' $ 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 = P.fromAbs bd' `P.combine` x
|
||||
let sfp = (P.fromAbs . P.dirname $ p') `P.combine` x
|
||||
rsfp <- P.realPath sfp
|
||||
readFile 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 via `readFile` and fills the free variable via `getFileInfo`.
|
||||
readFileWithFileInfo :: Path Abs -> IO (AnchoredFile FileInfo)
|
||||
readFileWithFileInfo = readFile getFileInfo
|
||||
return $ SymLink p' fv resolvedSyml x
|
||||
| PF.isDirectory fs = return $ Dir p' fv
|
||||
| PF.isRegularFile fs = return $ RegFile p' fv
|
||||
| PF.isBlockDevice fs = return $ BlockDev p' fv
|
||||
| PF.isCharacterDevice fs = return $ CharDev p' fv
|
||||
| PF.isNamedPipe fs = return $ NamedPipe p' fv
|
||||
| PF.isSocket fs = return $ Socket p' fv
|
||||
| otherwise = return $ Failed p' (userError
|
||||
"Unknown filetype!")
|
||||
|
||||
|
||||
-- |Same as readDirectoryContents but allows us to, for example, use
|
||||
-- ByteString.readFile to return a tree of ByteStrings.
|
||||
readDirectoryContents :: (Path Abs -> IO [Path Fn])
|
||||
-> (Path Abs -> IO a)
|
||||
-> Path Abs
|
||||
-> IO [AnchoredFile a]
|
||||
readDirectoryContents getfiles ff p = do
|
||||
files <- getfiles p
|
||||
fcs <- mapM (\x -> readFile ff $ p P.</> x) files
|
||||
-- |Get the contents of a given directory and return them as a list
|
||||
-- of `AnchoredFile`.
|
||||
readDirectoryContents :: (Path Abs -> IO a) -- ^ fills free a variable
|
||||
-> Path Abs -- ^ path to read
|
||||
-> IO [File a]
|
||||
readDirectoryContents ff p = do
|
||||
files <- getDirsFiles p
|
||||
fcs <- mapM (readFile ff) files
|
||||
return $ removeNonexistent fcs
|
||||
|
||||
|
||||
-- |A variant of `readDirectoryContents` which uses `readFileUnsafe`.
|
||||
-- Suitable for cases where we know the paths are safe/correct
|
||||
-- and need the extra bit of performance.
|
||||
readDirectoryContentsUnsafe :: (Path Abs -> IO [Path Fn])
|
||||
-> (Path Abs -> IO a)
|
||||
-> Path Abs
|
||||
-> IO [AnchoredFile a]
|
||||
readDirectoryContentsUnsafe getfiles ff p = do
|
||||
files <- getfiles p
|
||||
fcs <- mapM (\x -> readFileUnsafe ff $ p P.</> x) files
|
||||
return $ removeNonexistent fcs
|
||||
-- |A variant of `readDirectoryContents` where the third argument
|
||||
-- is a `File`. If a non-directory is passed returns an empty list.
|
||||
getContents :: (Path Abs -> IO a)
|
||||
-> File FileInfo
|
||||
-> IO [File a]
|
||||
getContents ff (DirOrSym af)
|
||||
= readDirectoryContents ff (fullPath af)
|
||||
getContents _ _ = return []
|
||||
|
||||
|
||||
-- |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.
|
||||
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
|
||||
goUp af@(Path "" :/ _) = return af
|
||||
goUp (bp :/ _) = readFile getFileInfo bp
|
||||
goUp :: File FileInfo -> IO (File FileInfo)
|
||||
goUp file = readFile getFileInfo (P.dirname . path $ file)
|
||||
|
||||
|
||||
-- |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
|
||||
|
||||
|
||||
|
|
@ -539,7 +400,7 @@ 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')
|
||||
comparingConstr t t' = compare (path t) (path t')
|
||||
|
||||
|
||||
|
||||
|
|
@ -594,48 +455,28 @@ isSocketC _ = False
|
|||
---- IO HELPERS: ----
|
||||
|
||||
|
||||
-- |Gets all filenames of the given directory.
|
||||
-- The first argument is a filter function that allows to exclude
|
||||
-- filenames from the result.
|
||||
getDirsFiles' :: (Path Fn -> [Path Fn] -> [Path Fn]) -- ^ filter function
|
||||
-> Path Abs -- ^ dir to read
|
||||
-> IO [Path Fn]
|
||||
getDirsFiles' filterf fp =
|
||||
-- |Gets all filenames of the given directory. This excludes "." and "..".
|
||||
getDirsFiles :: Path Abs -- ^ dir to read
|
||||
-> IO [Path Abs]
|
||||
getDirsFiles fp =
|
||||
rethrowErrnoAs [eACCES] (Can'tOpenDirectory . P.fromAbs $ fp)
|
||||
$ bracket (PFD.openDirStream . P.toFilePath $ fp)
|
||||
PFD.closeDirStream
|
||||
$ \dirstream ->
|
||||
let mdirs :: [Path Fn] -> IO [Path Fn]
|
||||
let mdirs :: [Path Abs] -> IO [Path Abs]
|
||||
mdirs dirs = do
|
||||
-- make sure we close the directory stream in case of errors
|
||||
-- TODO: more explicit error handling?
|
||||
-- both the parsing and readin the stream can fail!
|
||||
dir <- PFD.readDirStream dirstream
|
||||
case dir of
|
||||
"" -> return dirs
|
||||
_ -> do
|
||||
pdir <- P.parseFn dir
|
||||
mdirs $ pdir `filterf` dirs
|
||||
if B.null dir
|
||||
then return dirs
|
||||
else mdirs $ maybe dirs
|
||||
(\x -> fp P.</> x : dirs)
|
||||
(P.parseFn dir)
|
||||
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.
|
||||
getFileInfo :: Path Abs -> IO FileInfo
|
||||
getFileInfo fp = do
|
||||
|
|
@ -664,11 +505,10 @@ getFileInfo fp = do
|
|||
-- Handles an IO exception by returning a Failed constructor filled with that
|
||||
-- exception. Does not handle FmIOExceptions.
|
||||
handleDT :: Path Abs
|
||||
-> Path Fn
|
||||
-> IO (AnchoredFile a)
|
||||
-> IO (AnchoredFile a)
|
||||
handleDT bp n
|
||||
= handleIOError $ \e -> return $ bp :/ Failed n e
|
||||
-> IO (File a)
|
||||
-> IO (File a)
|
||||
handleDT p
|
||||
= handleIOError $ \e -> return $ Failed p e
|
||||
|
||||
|
||||
-- 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
|
||||
-- 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 :: [File a] -> [File a]
|
||||
removeNonexistent = filter isOkConstructor
|
||||
where
|
||||
isOkConstructor (_ :/ c) = not (failed c) || isOkError c
|
||||
isOkConstructor c = not (failed c) || isOkError c
|
||||
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
|
||||
|
||||
|
||||
|
|
@ -692,7 +532,7 @@ removeNonexistent = filter isOkConstructor
|
|||
--
|
||||
-- When called on a non-symlink, returns False.
|
||||
isBrokenSymlink :: File FileInfo -> Bool
|
||||
isBrokenSymlink (SymLink _ _ (_ :/ Failed {}) _) = True
|
||||
isBrokenSymlink (SymLink _ _ Failed{} _) = True
|
||||
isBrokenSymlink _ = False
|
||||
|
||||
|
||||
|
|
@ -718,12 +558,12 @@ getFreeVar _ = Nothing
|
|||
|
||||
|
||||
-- |Get the full path of the file.
|
||||
fullPath :: AnchoredFile a -> Path Abs
|
||||
fullPath (bp :/ f) = bp P.</> name f
|
||||
fullPath :: File a -> Path Abs
|
||||
fullPath f = path f
|
||||
|
||||
|
||||
-- |Get the full path of the file, converted to a `FilePath`.
|
||||
fullPathS :: AnchoredFile a -> ByteString
|
||||
fullPathS :: File a -> ByteString
|
||||
fullPathS = P.fromAbs . fullPath
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -58,6 +58,7 @@ import HSFM.GUI.Gtk.Dialogs
|
|||
import HSFM.GUI.Gtk.MyView
|
||||
import HSFM.GUI.Gtk.Utils
|
||||
import HSFM.Utils.IO
|
||||
import Prelude hiding(readFile)
|
||||
import System.Glib.UTFString
|
||||
(
|
||||
glibToString
|
||||
|
|
@ -237,8 +238,8 @@ urlGoTo mygui myview = withErrorDialog $ do
|
|||
open :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
open [item] mygui myview = withErrorDialog $
|
||||
case item of
|
||||
ADirOrSym r -> do
|
||||
nv <- HSFM.FileSystem.FileType.readFileWithFileInfo $ fullPath r
|
||||
DirOrSym r -> do
|
||||
nv <- readFile getFileInfo $ fullPath r
|
||||
refreshView' mygui myview nv
|
||||
r ->
|
||||
void $ openFile r
|
||||
|
|
@ -356,7 +357,8 @@ renameF [item] _ _ = withErrorDialog $ do
|
|||
for_ pmfn $ \fn -> do
|
||||
let cmsg = "Really rename \"" ++ P.fpToString (fullPathS item)
|
||||
++ "\"" ++ " to \""
|
||||
++ P.fpToString (P.fromAbs (anchor item P.</> fn)) ++ "\"?"
|
||||
++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
|
||||
P.</> fn) ++ "\"?"
|
||||
withConfirmationDialog cmsg $
|
||||
HSFM.FileSystem.FileOperations.renameFile item fn
|
||||
renameF _ _ _ = withErrorDialog
|
||||
|
|
|
|||
|
|
@ -91,13 +91,14 @@ data FMSettings = MkFMSettings {
|
|||
data FMView = FMTreeView TreeView
|
||||
| FMIconView IconView
|
||||
|
||||
type Item = AnchoredFile FileInfo
|
||||
type Item = File FileInfo
|
||||
|
||||
|
||||
-- |This describes the contents of the current vie and is separated from MyGUI,
|
||||
-- because we might want to have multiple views.
|
||||
data MyView = MkMyView {
|
||||
view :: TVar FMView
|
||||
, cwd :: MVar Item
|
||||
, rawModel :: TVar (ListStore Item)
|
||||
, sortedModel :: TVar (TypedTreeModelSort Item)
|
||||
, filteredModel :: TVar (TypedTreeModelFilter Item)
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@ import Data.Foldable
|
|||
import Data.Maybe
|
||||
(
|
||||
catMaybes
|
||||
, fromJust
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
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.Utils
|
||||
import HSFM.Utils.IO
|
||||
import Prelude hiding(readFile)
|
||||
import System.INotify
|
||||
(
|
||||
addWatch
|
||||
|
|
@ -79,7 +81,9 @@ import System.IO.Error
|
|||
|
||||
-- |Constructs the initial MyView object with a few dummy models.
|
||||
-- It also initializes the callbacks.
|
||||
createMyView :: MyGUI -> IO FMView -> IO MyView
|
||||
createMyView :: MyGUI
|
||||
-> IO FMView
|
||||
-> IO MyView
|
||||
createMyView mygui iofmv = do
|
||||
operationBuffer <- newTVarIO None
|
||||
|
||||
|
|
@ -91,7 +95,7 @@ createMyView mygui iofmv = do
|
|||
=<< readTVarIO rawModel
|
||||
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
|
||||
=<< readTVarIO filteredModel
|
||||
|
||||
cwd <- newEmptyMVar
|
||||
view' <- iofmv
|
||||
view <- newTVarIO view'
|
||||
|
||||
|
|
@ -194,6 +198,7 @@ createTreeView = do
|
|||
|
||||
|
||||
-- |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 that fails, it reads "/" instead.
|
||||
|
|
@ -208,12 +213,12 @@ refreshView mygui myview mfp =
|
|||
case mfp of
|
||||
Just fp -> do
|
||||
-- readFileWithFileInfo can just outright fail...
|
||||
ecdir <- tryIOError (HSFM.FileSystem.FileType.readFileWithFileInfo fp)
|
||||
ecdir <- tryIOError (readFile getFileInfo fp)
|
||||
case ecdir of
|
||||
Right cdir ->
|
||||
-- ...or return an `AnchordFile` with a Failed constructor,
|
||||
-- both of which need to be handled here
|
||||
if (failed . file $ cdir)
|
||||
if (failed cdir)
|
||||
then refreshView mygui myview =<< getAlternativeDir
|
||||
else refreshView' mygui myview cdir
|
||||
Left _ -> refreshView mygui myview =<< getAlternativeDir
|
||||
|
|
@ -221,7 +226,7 @@ refreshView mygui myview mfp =
|
|||
where
|
||||
getAlternativeDir = do
|
||||
ecd <- try (getCurrentDir myview) :: IO (Either SomeException
|
||||
(AnchoredFile FileInfo))
|
||||
Item)
|
||||
case ecd of
|
||||
Right dir -> return (Just $ fullPath dir)
|
||||
Left _ -> return (P.parseAbs "/")
|
||||
|
|
@ -233,14 +238,17 @@ refreshView mygui myview mfp =
|
|||
-- calls `refreshView` with the 3rd argument being Nothing.
|
||||
refreshView' :: MyGUI
|
||||
-> MyView
|
||||
-> AnchoredFile FileInfo
|
||||
-> Item
|
||||
-> IO ()
|
||||
refreshView' mygui myview dt@(ADirOrSym _) = do
|
||||
refreshView' mygui myview dt@(DirOrSym _) = do
|
||||
newRawModel <- fileListStore dt myview
|
||||
writeTVarIO (rawModel myview) newRawModel
|
||||
|
||||
view' <- readTVarIO $ view myview
|
||||
|
||||
_ <- tryTakeMVar (cwd myview)
|
||||
putMVar (cwd myview) dt
|
||||
|
||||
-- get selected items
|
||||
tps <- getSelectedTreePaths mygui myview
|
||||
trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
|
||||
|
|
@ -255,7 +263,7 @@ refreshView' mygui myview dt@(ADirOrSym _) = do
|
|||
ntps <- mapM treeRowReferenceGetPath trs
|
||||
mapM_ (treeSelectionSelectPath tvs) ntps
|
||||
_ -> return ()
|
||||
refreshView' mygui myview (_ :/ Failed{}) = refreshView mygui myview Nothing
|
||||
refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
|
||||
refreshView' _ _ _ = return ()
|
||||
|
||||
|
||||
|
|
@ -288,7 +296,7 @@ constructView mygui myview = do
|
|||
|
||||
view' <- readTVarIO $ view myview
|
||||
|
||||
cdirp <- anchor <$> getFirstItem myview
|
||||
cdirp <- path <$> getCurrentDir myview
|
||||
|
||||
-- update urlBar
|
||||
entrySetText (urlBar mygui) (P.fromAbs cdirp)
|
||||
|
|
@ -300,7 +308,7 @@ constructView mygui myview = do
|
|||
writeTVarIO (filteredModel myview) filteredModel'
|
||||
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
|
||||
hidden <- showHidden <$> readTVarIO (settings mygui)
|
||||
item <- (name . file) <$> treeModelGetRow rawModel' iter
|
||||
item <- treeModelGetRow rawModel' iter >>= (P.basename . path)
|
||||
if hidden
|
||||
then return True
|
||||
else return $ not . P.hiddenFile $ item
|
||||
|
|
@ -318,13 +326,13 @@ constructView mygui myview = do
|
|||
|
||||
-- set values
|
||||
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
|
||||
(dirtreePix . file)
|
||||
dirtreePix
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 1)
|
||||
(P.fromRel . name . file)
|
||||
(P.toFilePath . fromJust . P.basename . path)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 2)
|
||||
(packModTime . file)
|
||||
packModTime
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 3)
|
||||
(packPermissions . file)
|
||||
packPermissions
|
||||
|
||||
-- update model of view
|
||||
case view' of
|
||||
|
|
|
|||
|
|
@ -21,6 +21,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
|||
module HSFM.GUI.Gtk.Utils where
|
||||
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
(
|
||||
readMVar
|
||||
)
|
||||
import Control.Concurrent.STM
|
||||
(
|
||||
readTVarIO
|
||||
|
|
@ -37,6 +41,7 @@ import Data.Traversable
|
|||
import Graphics.UI.Gtk
|
||||
import HSFM.FileSystem.FileType
|
||||
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.
|
||||
-- This is the function which maps the Data.DirTree data structures
|
||||
-- into the GTK+ data structures.
|
||||
fileListStore :: AnchoredFile FileInfo -- ^ current dir
|
||||
fileListStore :: Item -- ^ current dir
|
||||
-> MyView
|
||||
-> IO (ListStore Item)
|
||||
fileListStore dt _ = do
|
||||
cs <- HSFM.FileSystem.FileType.getContents dt
|
||||
cs <- getContents getFileInfo dt
|
||||
listStoreNew cs
|
||||
|
||||
|
||||
-- |Currently unsafe. This is used to obtain any item (possibly the '.' item)
|
||||
-- and extract the "current working directory" from it.
|
||||
-- |Currently unsafe. This is used to obtain any item, which will
|
||||
-- fail if there is none.
|
||||
getFirstItem :: MyView
|
||||
-> IO (AnchoredFile FileInfo)
|
||||
-> IO Item
|
||||
getFirstItem myview = do
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
iter <- fromJust <$> treeModelGetIterFirst rawModel'
|
||||
treeModelGetRow rawModel' iter
|
||||
|
||||
|
||||
-- |Currently unsafe. Gets the current directory via `getFirstItem` and
|
||||
-- `goUp`.
|
||||
-- |Reads the current directory from MyView.
|
||||
getCurrentDir :: MyView
|
||||
-> IO (AnchoredFile FileInfo)
|
||||
getCurrentDir myview = getFirstItem myview >>= goUp
|
||||
-> IO Item
|
||||
getCurrentDir myview = readMVar (cwd myview)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue