hasufell/hsfm
1
1
Fork 0
Code Issues 33 Pull Requests Releases Wiki Activity

LIB/GTK: use new data structure with explicit SymLink constructor

Browse Source 
This still needs a lot of work to function consistently, but it's better
than the old approach.
This commit is contained in:
Julian Ospald 2015-12-23 22:50:04 +01:00
parent 06b96eecea
commit 5f183bef3f
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
5 changed files with 198 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

289
src/Data/DirTree.hs
View File

@ -83,6 +83,7 @@ import System.FilePath
combine combine
, normalise , normalise
, equalFilePath , equalFilePath
, isAbsolute
, joinPath , joinPath
, splitDirectories , splitDirectories
, takeFileName , takeFileName
@ -141,8 +142,8 @@ type FileName = String
-- |Represents a file. The `anchor` field is the path -- |Represents a file. The `anchor` field is the path
-- to that file without the filename. -- to that file without the filename.
data AnchoredFile a b = data AnchoredFile a =
(:/) { anchor :: FilePath, file :: File a b } (:/) { anchor :: FilePath, file :: File a }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
@ -151,18 +152,40 @@ data AnchoredFile a b =
-- 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 b = data File a =
Failed { Failed {
name :: FileName name :: FileName
, err :: IOException , err :: IOException
} }
| Dir { | Dir {
name :: FileName name :: FileName
, dir :: a , fvar :: a
} }
| RegFile { | RegFile {
name :: FileName name :: FileName
, regFile :: b , fvar :: a
}
| SymLink {
name :: FileName
, fvar :: a
, sdest :: AnchoredFile a -- ^ symlink madness,
-- we need to know where it points to
}
| BlockDev {
name :: FileName
, fvar :: a
}
| CharDev {
name :: FileName
, fvar :: a
}
| NamedPipe {
name :: FileName
, fvar :: a
}
| Socket {
name :: FileName
, fvar :: a
} deriving (Show, Eq) } deriving (Show, Eq)
@ -182,34 +205,31 @@ data FileInfo = FileInfo {
, accessTimeHiRes :: POSIXTime , accessTimeHiRes :: POSIXTime
, modificationTimeHiRes :: POSIXTime , modificationTimeHiRes :: POSIXTime
, statusChangeTimeHiRes :: POSIXTime , statusChangeTimeHiRes :: POSIXTime
, isBlockDevice :: Bool
, isCharacterDevice :: Bool
, isNamedPipe :: Bool
, isRegularFile :: Bool
, isDirectory :: Bool
, isSymbolicLink :: Bool
, isSocket :: Bool
, permissions :: Permissions
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
isSymL :: AnchoredFile FileInfo FileInfo type UserIO a = FilePath -> IO a
-> (Bool, AnchoredFile FileInfo FileInfo)
isSymL f@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) = (True, f) type Builder a = UserIO a -> FilePath -> IO [File a]
isSymL f@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) = (True, f)
isSymL f = (False, f)
symlOrRegFile :: AnchoredFile FileInfo FileInfo symlOrRegFile :: AnchoredFile FileInfo
-> (Bool, AnchoredFile FileInfo FileInfo) -> (Bool, AnchoredFile FileInfo)
symlOrRegFile f@(_ :/ RegFile {}) = (True, f) symlOrRegFile f@(_ :/ RegFile {}) = (True, f)
symlOrRegFile f@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) = (True, f) symlOrRegFile f@(_ :/ SymLink {}) = (True, f)
symlOrRegFile f = (False, f) symlOrRegFile f = (False, f)
pattern IsSymL b <- (isSymL -> (b, _)) sdir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
sdir f@(_ :/ SymLink { sdest = (_ :/ Dir {} )}) = (True, f)
sdir f@(_ :/ Dir {}) = (True, f)
sdir f = (False, f)
pattern SymlOrRegFile <- (symlOrRegFile -> (True, _)) pattern SymlOrRegFile <- (symlOrRegFile -> (True, _))
pattern SDir f <- (sdir -> (True, f))
---------------------------- ----------------------------
@ -217,28 +237,10 @@ pattern SymlOrRegFile <- (symlOrRegFile -> (True, _))
---------------------------- ----------------------------
instance BF.Bifunctor File where
bimap = BT.bimapDefault
instance BFL.Bifoldable File where
bifoldMap = BT.bifoldMapDefault
instance BT.Bitraversable File where
bitraverse f1 f2 (Dir n b) =
Dir n <$> f1 b
bitraverse _ f2 (RegFile n a) =
RegFile n <$> f2 a
bitraverse _ _ (Failed n e) =
pure (Failed n e)
-- | First compare constructors: Failed < Dir < File... -- | First compare constructors: Failed < Dir < File...
-- Then compare `name`... -- Then compare `name`...
-- Then compare free variable parameter of `File` constructors -- Then compare free variable parameter of `File` constructors
instance (Ord a, Ord b, Eq a, Eq b) => Ord (File a b) where instance (Ord a, Eq a) => Ord (File a) where
compare (RegFile n a) (RegFile n' a') = compare (RegFile n a) (RegFile n' a') =
case compare n n' of case compare n n' of
EQ -> compare a a' EQ -> compare a a'
@ -261,96 +263,75 @@ instance (Ord a, Ord b, Eq a, Eq b) => Ord (File a b) where
-- |Read a file into an `AnchoredFile`, filling the free variables via -- |Read a file into an `AnchoredFile`, filling the free variables via
-- `getFileInfo`. This also works on directories, but doesn't look at -- the given function.
-- their contents.
readFileWith :: (FilePath -> IO a) readFileWith :: (FilePath -> IO a)
-> (FilePath -> IO b)
-> FilePath -> FilePath
-> IO (AnchoredFile a b) -> IO (AnchoredFile a)
readFileWith fd ff fp = do readFileWith ff p = do
let fn = topDir fp let fn = topDir p
bd = baseDir fp bd = baseDir p
file <- handleDT (topDir fp) $ do handleDT' bd fn $ do
isFile <- doesFileExist fp fs <- PF.getSymbolicLinkStatus p
if isFile fv <- ff p
then RegFile fn <$> ff fp file <- constructFile fs fv bd fn
else Dir fn <$> fd fp return (bd :/ file)
return (bd :/ file) where
constructFile fs fv bd' n
| PF.isSymbolicLink fs = do
-- symlink madness, we need to make sure we save the correct
-- AnchoredFile
let fp = bd' </> n
resolvedSyml <- handleDT' bd' n $ do
sfp <- (\x -> if isAbsolute x then x else bd' </> x)
<$> PF.readSymbolicLink fp
_ <- PF.getFileStatus sfp -- important to break infinite symbolic
-- link cycle
readFileWith ff sfp
return $ SymLink n fv resolvedSyml
| PF.isDirectory fs = return $ Dir n fv
| PF.isRegularFile fs = return $ RegFile n fv
| PF.isBlockDevice fs = return $ BlockDev n fv
| PF.isCharacterDevice fs = return $ CharDev n fv
| PF.isNamedPipe fs = return $ NamedPipe n fv
| PF.isSocket fs = return $ Socket n fv
| otherwise = return $ Failed n (userError
"Unknown filetype!")
readFile :: FilePath -> IO (AnchoredFile FileInfo FileInfo) readFile :: FilePath -> IO (AnchoredFile FileInfo)
readFile fp = readFileWith getFileInfo getFileInfo =<< canonicalizePath' fp readFile fp = readFileWith getFileInfo =<< canonicalizePath' fp
-- |Build a list of AnchoredFile, given the path to a directory, filling -- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This includes the "." and ".." -- the free variables via `getFileInfo`. This includes the "." and ".."
-- directories. -- directories.
readDirectory :: FilePath -> IO [AnchoredFile FileInfo FileInfo] readDirectory :: FilePath -> IO [AnchoredFile FileInfo]
readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo getFileInfo readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo
=<< canonicalizePath' fp =<< canonicalizePath' fp
-- |Build a list of AnchoredFile, given the path to a directory, filling -- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This excludes the "." and ".." -- the free variables via `getFileInfo`. This excludes the "." and ".."
-- directories. -- directories.
readDirectory' :: FilePath -> IO [AnchoredFile FileInfo FileInfo] readDirectory' :: FilePath -> IO [AnchoredFile FileInfo]
readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo getFileInfo readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo
=<< canonicalizePath' fp =<< canonicalizePath' fp
-- | same as readDirectory but allows us to, for example, use -- | same as readDirectory but allows us to, for example, use
-- ByteString.readFile to return a tree of ByteStrings. -- ByteString.readFile to return a tree of ByteStrings.
readDirectoryWith :: (FilePath -> IO [FilePath]) readDirectoryWith :: (FilePath -> IO [FilePath])
-> (FilePath -> IO a) -> (FilePath -> IO a)
-> (FilePath -> IO b)
-> FilePath -> FilePath
-> IO [AnchoredFile a b] -> IO [AnchoredFile a]
readDirectoryWith getfiles fd ff p = buildWith' (buildAtOnce' getfiles) fd ff readDirectoryWith getfiles ff p = do
=<< canonicalizePath' p contents <- getfiles =<< canonicalizePath' p
cs <- mapM (\x -> readFileWith ff $ p </> x) contents
return $ removeNonexistent cs
-----------------------------
--[ LOWER LEVEL FUNCTIONS ]--
-----------------------------
-- -- -- helpers: -- -- --
type UserIO a = FilePath -> IO a
type Builder a b = UserIO a -> UserIO b -> FilePath -> IO [File a b]
-- remove non-existent file errors, which are artifacts of the "non-atomic"
-- nature of traversing a system firectory tree:
buildWith' :: Builder a b
-> UserIO a
-> UserIO b
-> FilePath
-> IO [AnchoredFile a b]
buildWith' bf' fd ff p =
do
cfp <- canonicalizePath' p
tree <- bf' fd ff cfp
return $ fmap (cfp :/) (removeNonexistent tree)
-- IO function passed to our builder and finally executed here:
buildAtOnce' :: (FilePath -> IO [FilePath]) -> Builder a b
buildAtOnce' getfiles fd ff fp = do
contents <- getfiles fp
for contents $ \n -> handleDT n $ do
let subf = fp </> n
do isFile <- doesFileExist subf
if isFile
then RegFile n <$> ff subf
else Dir n <$> fd subf
----------------- -----------------
--[ UTILITIES ]-- --[ UTILITIES ]--
@ -362,22 +343,22 @@ buildAtOnce' getfiles fd ff fp = do
-- | True if any Failed constructors in the tree -- | True if any Failed constructors in the tree
anyFailed :: [File a b] -> Bool anyFailed :: [File a] -> Bool
anyFailed = not . successful anyFailed = not . successful
-- | True if there are no Failed constructors in the tree -- | True if there are no Failed constructors in the tree
successful :: [File a b] -> Bool successful :: [File a] -> Bool
successful = null . failures successful = null . failures
-- | returns true if argument is a `Failed` constructor: -- | returns true if argument is a `Failed` constructor:
failed :: File a b -> Bool failed :: File a -> Bool
failed (Failed _ _) = True failed (Failed _ _) = True
failed _ = False failed _ = False
-- | returns a list of 'Failed' constructors only: -- | returns a list of 'Failed' constructors only:
failures :: [File a b] -> [File a b] failures :: [File a] -> [File a]
failures = filter failed failures = filter failed
@ -387,21 +368,21 @@ failures = filter failed
-- | Tests equality of two trees, ignoring their free variable portion. Can be -- | Tests equality of two trees, ignoring their free variable portion. Can be
-- used to check if any files have been added or deleted, for instance. -- used to check if any files have been added or deleted, for instance.
equalShape :: File a b -> File c d -> Bool equalShape :: File a -> File b -> Bool
equalShape d d' = comparingShape d d' == EQ equalShape d d' = comparingShape d d' == EQ
-- TODO: we should use equalFilePath here, but how to sort properly? -- TODO: we should use equalFilePath here, but how to sort properly?
-- with System.Directory.canonicalizePath, before compare? -- with System.Directory.canonicalizePath, before compare?
-- | a compare function that ignores the free "file" type variable: -- | a compare function that ignores the free "file" type variable:
comparingShape :: File a b -> File c d -> Ordering comparingShape :: File a -> File b -> Ordering
comparingShape (Dir n _) (Dir n' _) = compare n n' comparingShape (Dir n _) (Dir n' _) = compare n n'
-- else simply compare the flat constructors, non-recursively: -- else simply compare the flat constructors, non-recursively:
comparingShape t t' = comparingConstr t t' comparingShape t t' = comparingConstr t t'
-- HELPER: a non-recursive comparison -- HELPER: a non-recursive comparison
comparingConstr :: File a b -> File a1 b1 -> Ordering comparingConstr :: File a -> File b -> Ordering
comparingConstr (Failed _ _) (Dir _ _) = LT comparingConstr (Failed _ _) (Dir _ _) = LT
comparingConstr (Failed _ _) (RegFile _ _) = LT comparingConstr (Failed _ _) (RegFile _ _) = LT
comparingConstr (RegFile _ _) (Failed _ _) = GT comparingConstr (RegFile _ _) (Failed _ _) = GT
@ -425,11 +406,11 @@ comparingConstr t t' = compare (name t) (name t')
---- CONSTRUCTOR IDENTIFIERS ---- ---- CONSTRUCTOR IDENTIFIERS ----
isFileC :: File a b -> Bool isFileC :: File a -> Bool
isFileC (RegFile _ _) = True isFileC (RegFile _ _) = True
isFileC _ = False isFileC _ = False
isDirC :: File a b -> Bool isDirC :: File a -> Bool
isDirC (Dir _ _) = True isDirC (Dir _ _) = True
isDirC _ = False isDirC _ = False
@ -481,20 +462,20 @@ canonicalizePath' fp = do
-- |Go up one directory in the filesystem hierarchy. -- |Go up one directory in the filesystem hierarchy.
goUp :: AnchoredFile FileInfo FileInfo -> IO (AnchoredFile FileInfo FileInfo) goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
goUp af@("" :/ _) = return af goUp af@("" :/ _) = return af
goUp (bp :/ _) = Data.DirTree.readFile bp goUp (bp :/ _) = Data.DirTree.readFile bp
goUp' :: FilePath -> IO (AnchoredFile FileInfo FileInfo) goUp' :: FilePath -> IO (AnchoredFile FileInfo)
goUp' fp = do goUp' fp = do
cfp <- canonicalizePath' fp cfp <- canonicalizePath' fp
Data.DirTree.readFile $ baseDir cfp Data.DirTree.readFile $ baseDir cfp
getContents :: AnchoredFile FileInfo FileInfo getContents :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo FileInfo] -> IO [AnchoredFile FileInfo]
getContents (bp :/ Dir n _) = readDirectory (bp </> n) getContents (SDir af) = readDirectory (fullPath af)
getContents _ = return [] getContents _ = return []
@ -539,7 +520,6 @@ getDirsFiles fp = do
getFileInfo :: FilePath -> IO FileInfo getFileInfo :: FilePath -> IO FileInfo
getFileInfo fp = do getFileInfo fp = do
fs <- PF.getSymbolicLinkStatus fp fs <- PF.getSymbolicLinkStatus fp
perms <- getPermissions fp
return $ FileInfo return $ FileInfo
(PF.deviceID fs) (PF.deviceID fs)
(PF.fileID fs) (PF.fileID fs)
@ -555,18 +535,10 @@ getFileInfo fp = do
(PF.accessTimeHiRes fs) (PF.accessTimeHiRes fs)
(PF.modificationTimeHiRes fs) (PF.modificationTimeHiRes fs)
(PF.statusChangeTimeHiRes fs) (PF.statusChangeTimeHiRes fs)
(PF.isBlockDevice fs)
(PF.isCharacterDevice fs)
(PF.isNamedPipe fs)
(PF.isRegularFile fs)
(PF.isDirectory fs)
(PF.isSymbolicLink fs)
(PF.isSocket fs)
perms
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`. -- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
getFreeVar :: File a a -> Maybe a getFreeVar :: File a -> Maybe a
getFreeVar (RegFile _ f) = Just f getFreeVar (RegFile _ f) = Just f
getFreeVar (Dir _ d) = Just d getFreeVar (Dir _ d) = Just d
getFreeVar _ = Nothing getFreeVar _ = Nothing
@ -577,20 +549,27 @@ getFreeVar _ = Nothing
-- 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: -- exception:
handleDT :: FileName -> IO (File a b) -> IO (File a b) handleDT :: FileName -> IO (File a) -> IO (File a)
handleDT n = handle (return . Failed n) handleDT n = handle (return . Failed n)
-- handles an IO exception by returning a Failed constructor filled with that
-- exception:
handleDT' :: FilePath -> FileName -> IO (AnchoredFile a) -> IO (AnchoredFile a)
handleDT' bp n = handle (\e -> return $ bp :/ Failed n e)
-- DoesNotExist errors not present at the topmost level could happen if a -- DoesNotExist errors not present at the topmost level could happen if a
-- named file or directory is deleted after being listed by -- named file or directory is deleted after being listed by
-- getDirectoryContents but before we can get it into memory. -- getDirectoryContents but before we can get it into memory.
-- 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 :: [File a b] -> [File a b] removeNonexistent :: [AnchoredFile a] -> [AnchoredFile a]
removeNonexistent = filter isOkConstructor removeNonexistent = filter isOkConstructor
where isOkConstructor c = not (failed c) || isOkError c where
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err isOkConstructor (_ :/ c) = not (failed c) || isOkError c
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
@ -598,11 +577,11 @@ removeNonexistent = filter isOkConstructor
---- OTHER: ---- ---- OTHER: ----
fullPath :: AnchoredFile a b -> FilePath fullPath :: AnchoredFile a -> FilePath
fullPath (bp :/ f) = bp </> name f fullPath (bp :/ f) = bp </> name f
fromFreeVar :: (Default d) => (a -> d) -> File a a -> d fromFreeVar :: (Default d) => (a -> d) -> File a -> d
fromFreeVar f df = maybeD f $ getFreeVar df fromFreeVar f df = maybeD f $ getFreeVar df
@ -610,20 +589,38 @@ maybeD :: (Default b) => (a -> b) -> Maybe a -> b
maybeD = maybe def maybeD = maybe def
-- |Pack the modification time -- |Pack the modification time into a string.
packModTime :: File FileInfo FileInfo packModTime :: File FileInfo
-> String -> String
packModTime = fromFreeVar packModTime = fromFreeVar
$ show . posixSecondsToUTCTime . realToFrac . modificationTime $ show . posixSecondsToUTCTime . realToFrac . modificationTime
packPermissions :: File FileInfo FileInfo
-- |Pack the permissions into a string, similar to what "ls -l" does.
packPermissions :: File FileInfo
-> String -> String
packPermissions dt = fromFreeVar (pStr . permissions) dt packPermissions dt = fromFreeVar (pStr . fileMode) dt
where where
pStr perm = str perm readable "r" pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
++ str perm writable "w" where
++ str perm (if isDirC dt then searchable else executable) typeModeStr
"x" | hasFM PF.regularFileMode = "-"
str perm f ch | hasFM PF.directoryMode = "d"
| f perm = ch | hasFM PF.symbolicLinkMode = "l"
| otherwise = "-" | hasFM PF.socketMode = "s"
| hasFM PF.blockSpecialMode = "b"
| hasFM PF.characterSpecialMode = "c"
| hasFM PF.namedPipeMode = "p"
ownerModeStr = hasFmStr PF.ownerReadMode "r"
++ hasFmStr PF.ownerWriteMode "w"
++ hasFmStr PF.ownerExecuteMode "x"
groupModeStr = hasFmStr PF.groupReadMode "r"
++ hasFmStr PF.groupWriteMode "w"
++ hasFmStr PF.groupExecuteMode "x"
otherModeStr = hasFmStr PF.otherReadMode "r"
++ hasFmStr PF.otherWriteMode "w"
++ hasFmStr PF.otherExecuteMode "x"
hasFmStr fm str
| hasFM fm = str
| otherwise = "-"
hasFM fm = ffm `PF.intersectFileModes` fm == fm

2
src/GUI/Gtk/Callbacks.hs
View File

@ -111,7 +111,7 @@ urlGoTo mygui myview = do
open :: Row -> MyGUI -> MyView -> IO () open :: Row -> MyGUI -> MyView -> IO ()
open row mygui myview = withErrorDialog $ open row mygui myview = withErrorDialog $
case row of case row of
r@(_ :/ Dir _ _) -> do SDir r -> do
nv <- Data.DirTree.readFile $ fullPath r nv <- Data.DirTree.readFile $ fullPath r
refreshTreeView' mygui myview nv refreshTreeView' mygui myview nv
r -> r ->

2
src/GUI/Gtk/Data.hs
View File

@ -56,7 +56,7 @@ data FMSettings = MkFMSettings {
} }
type Row = AnchoredFile FileInfo FileInfo type Row = AnchoredFile FileInfo
-- |This describes the contents of the treeView and is separated from MyGUI, -- |This describes the contents of the treeView and is separated from MyGUI,

7
src/GUI/Gtk/Utils.hs
View File

@ -85,7 +85,7 @@ withRow 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 FileInfo -- ^ current dir fileListStore :: AnchoredFile FileInfo -- ^ current dir
-> MyView -> MyView
-> IO (ListStore Row) -> IO (ListStore Row)
fileListStore dt myview = do fileListStore dt myview = do
@ -100,7 +100,7 @@ fileListStore dt myview = do
-- --
-- * 'rawModel' reads -- * 'rawModel' reads
getFirstRow :: MyView getFirstRow :: MyView
-> IO (AnchoredFile FileInfo FileInfo) -> IO (AnchoredFile FileInfo)
getFirstRow myview = do getFirstRow myview = do
rawModel' <- readTVarIO $ rawModel myview rawModel' <- readTVarIO $ rawModel myview
iter <- fromJust <$> treeModelGetIterFirst rawModel' iter <- fromJust <$> treeModelGetIterFirst rawModel'
@ -141,7 +141,7 @@ refreshTreeView mygui myview mfp = do
-- * 'rawModel' writes -- * 'rawModel' writes
refreshTreeView' :: MyGUI refreshTreeView' :: MyGUI
-> MyView -> MyView
-> AnchoredFile FileInfo FileInfo -> AnchoredFile FileInfo
-> IO () -> IO ()
refreshTreeView' mygui myview dt = do refreshTreeView' mygui myview dt = do
newRawModel <- fileListStore dt myview newRawModel <- fileListStore dt myview
@ -215,6 +215,7 @@ constructTreeView mygui myview = do
dirtreePix (Dir {}) = folderPix mygui dirtreePix (Dir {}) = folderPix mygui
dirtreePix (RegFile {}) = filePix mygui dirtreePix (RegFile {}) = filePix mygui
dirtreePix (Failed {}) = errorPix mygui dirtreePix (Failed {}) = errorPix mygui
dirtreePix _ = errorPix mygui
-- |Push a message to the status bar. -- |Push a message to the status bar.

100
src/IO/File.hs
View File

@ -77,27 +77,27 @@ import qualified System.Posix.Files as PF
-- or delay operations. -- or delay operations.
data FileOperation = FCopy Copy data FileOperation = FCopy Copy
| FMove Move | FMove Move
| FDelete (AnchoredFile FileInfo FileInfo) | FDelete (AnchoredFile FileInfo)
| FOpen (AnchoredFile FileInfo FileInfo) | FOpen (AnchoredFile FileInfo)
| FExecute (AnchoredFile FileInfo FileInfo) [String] | FExecute (AnchoredFile FileInfo) [String]
| None | None
-- |Data type describing partial or complete file copy operation. -- |Data type describing partial or complete file copy operation.
-- CC stands for a complete operation and can be used for `runFileOp`. -- CC stands for a complete operation and can be used for `runFileOp`.
data Copy = CP1 (AnchoredFile FileInfo FileInfo) data Copy = CP1 (AnchoredFile FileInfo)
| CP2 (AnchoredFile FileInfo FileInfo) | CP2 (AnchoredFile FileInfo)
(AnchoredFile FileInfo FileInfo) (AnchoredFile FileInfo)
| CC (AnchoredFile FileInfo FileInfo) | CC (AnchoredFile FileInfo)
(AnchoredFile FileInfo FileInfo) (AnchoredFile FileInfo)
DirCopyMode DirCopyMode
-- |Data type describing partial or complete file move operation. -- |Data type describing partial or complete file move operation.
-- MC stands for a complete operation and can be used for `runFileOp`. -- MC stands for a complete operation and can be used for `runFileOp`.
data Move = MP1 (AnchoredFile FileInfo FileInfo) data Move = MP1 (AnchoredFile FileInfo)
| MC (AnchoredFile FileInfo FileInfo) | MC (AnchoredFile FileInfo)
(AnchoredFile FileInfo FileInfo) (AnchoredFile FileInfo)
-- |Directory copy modes. -- |Directory copy modes.
@ -129,11 +129,10 @@ runFileOp _ = return Nothing
-- |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 :: DirCopyMode copyDir :: DirCopyMode
-> AnchoredFile FileInfo FileInfo -- ^ source dir -> AnchoredFile FileInfo -- ^ source dir
-> AnchoredFile FileInfo FileInfo -- ^ destination dir -> AnchoredFile FileInfo -- ^ destination dir
-> IO () -> IO ()
copyDir cm (IsSymL True) _ copyDir cm (_ :/ SymLink {}) _ = return ()
= return ()
copyDir cm from@(_ :/ Dir fromn _) copyDir cm from@(_ :/ Dir fromn _)
to@(_ :/ Dir {}) to@(_ :/ Dir {})
= do = do
@ -150,7 +149,7 @@ copyDir cm from@(_ :/ Dir fromn _)
for_ contents $ \f -> for_ contents $ \f ->
case f of case f of
(IsSymL True) -> recreateSymlink f destdir (_ :/ SymLink {}) -> recreateSymlink f destdir
(_ :/ Dir {}) -> copyDir cm f destdir (_ :/ Dir {}) -> copyDir cm f destdir
(_ :/ RegFile {}) -> copyFileToDir f destdir (_ :/ RegFile {}) -> copyFileToDir f destdir
_ -> return () _ -> return ()
@ -179,11 +178,11 @@ copyDir _ _ _ = return ()
-- |Recreate a symlink. -- |Recreate a symlink.
recreateSymlink :: AnchoredFile FileInfo FileInfo -- ^ the old symlink file recreateSymlink :: AnchoredFile FileInfo -- ^ the old symlink file
-> AnchoredFile FileInfo FileInfo -- ^ destination dir of the -> AnchoredFile FileInfo -- ^ destination dir of the
-- new symlink file -- new symlink file
-> IO () -> IO ()
recreateSymlink symf@(IsSymL True) recreateSymlink symf@(_ :/ SymLink {})
symdest@(_ :/ Dir {}) symdest@(_ :/ Dir {})
= do = do
symname <- readSymbolicLink (fullPath symf) symname <- readSymbolicLink (fullPath symf)
@ -193,10 +192,10 @@ recreateSymlink _ _ = return ()
-- |Copies the given file to the given file destination. -- |Copies the given file to the given file destination.
-- Excludes symlinks. -- Excludes symlinks.
copyFile :: AnchoredFile FileInfo FileInfo -- ^ source file copyFile :: AnchoredFile FileInfo -- ^ source file
-> AnchoredFile FileInfo FileInfo -- ^ destination file -> AnchoredFile FileInfo -- ^ destination file
-> IO () -> IO ()
copyFile (IsSymL True) _ = return () copyFile (_ :/ SymLink {}) _ = return ()
copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do
let from' = fullPath from let from' = fullPath from
to' = fullPath to to' = fullPath to
@ -207,10 +206,10 @@ copyFile _ _ = return ()
-- |Copies the given file to the given dir with the same filename. -- |Copies the given file to the given dir with the same filename.
-- Excludes symlinks. -- Excludes symlinks.
copyFileToDir :: AnchoredFile FileInfo FileInfo copyFileToDir :: AnchoredFile FileInfo
-> AnchoredFile FileInfo FileInfo -> AnchoredFile FileInfo
-> IO () -> IO ()
copyFileToDir (IsSymL True) _ = return () copyFileToDir (_ :/ SymLink {}) _ = return ()
copyFileToDir from@(_ :/ RegFile fn _) copyFileToDir from@(_ :/ RegFile fn _)
to@(_ :/ Dir {}) = to@(_ :/ Dir {}) =
do do
@ -223,10 +222,10 @@ copyFileToDir _ _ = return ()
-- |Copies a file, directory or symlink. In case of a symlink, it is just -- |Copies a file, directory or symlink. In case of a symlink, it is just
-- recreated, even if it points to a directory. -- recreated, even if it points to a directory.
easyCopy :: DirCopyMode easyCopy :: DirCopyMode
-> AnchoredFile FileInfo FileInfo -> AnchoredFile FileInfo
-> AnchoredFile FileInfo FileInfo -> AnchoredFile FileInfo
-> IO () -> IO ()
easyCopy _ from@(IsSymL True) to@(_ :/ Dir {}) = recreateSymlink from to easyCopy _ from@(_ :/ SymLink {}) to@(_ :/ Dir {}) = recreateSymlink from to
easyCopy _ from@(_ :/ RegFile fn _) easyCopy _ from@(_ :/ RegFile fn _)
to@(_ :/ Dir {}) to@(_ :/ Dir {})
= copyFileToDir from to = copyFileToDir from to
@ -249,8 +248,8 @@ easyCopy _ _ _ = return ()
-- |Move a given file to the given target directory. -- |Move a given file to the given target directory.
-- Includes symlinks, which are treated as files and the symlink is not -- Includes symlinks, which are treated as files and the symlink is not
-- followed. -- followed.
moveFile :: AnchoredFile FileInfo FileInfo -- ^ file to move moveFile :: AnchoredFile FileInfo -- ^ file to move
-> AnchoredFile FileInfo FileInfo -- ^ base target directory -> AnchoredFile FileInfo -- ^ base target directory
-> IO () -> IO ()
moveFile from@SymlOrRegFile to@(_ :/ Dir {}) = do moveFile from@SymlOrRegFile to@(_ :/ Dir {}) = do
let from' = fullPath from let from' = fullPath from
@ -262,10 +261,10 @@ moveFile _ _ = return ()
-- |Move a given directory to the given target directory. -- |Move a given directory to the given target directory.
-- Excludes symlinks. -- Excludes symlinks.
moveDir :: AnchoredFile FileInfo FileInfo -- ^ dir to move moveDir :: AnchoredFile FileInfo -- ^ dir to move
-> AnchoredFile FileInfo FileInfo -- ^ base target directory -> AnchoredFile FileInfo -- ^ base target directory
-> IO () -> IO ()
moveDir (IsSymL True) _ = return () moveDir (_ :/ SymLink {}) _ = return ()
moveDir from@(_ :/ Dir n _) to@(_ :/ Dir {}) = do moveDir from@(_ :/ Dir n _) to@(_ :/ Dir {}) = do
let from' = fullPath from let from' = fullPath from
to' = fullPath to </> n to' = fullPath to </> n
@ -276,10 +275,10 @@ moveDir _ _ = return ()
-- |Moves a file, directory or symlink. In case of a symlink, it is -- |Moves a file, directory or symlink. In case of a symlink, it is
-- treated as a file and the symlink is not being followed. -- treated as a file and the symlink is not being followed.
easyMove :: AnchoredFile FileInfo FileInfo -- ^ source easyMove :: AnchoredFile FileInfo -- ^ source
-> AnchoredFile FileInfo FileInfo -- ^ base target directory -> AnchoredFile FileInfo -- ^ base target directory
-> IO () -> IO ()
easyMove from@(IsSymL True) to@(_ :/ Dir {}) = moveFile from to easyMove from@(_ :/ SymLink {}) to@(_ :/ Dir {}) = moveFile from to
easyMove from@(_ :/ RegFile _ _) to@(_ :/ Dir {}) = moveFile from to easyMove from@(_ :/ RegFile _ _) to@(_ :/ Dir {}) = moveFile from to
easyMove from@(_ :/ Dir _ _) to@(_ :/ Dir {}) = moveDir from to easyMove from@(_ :/ Dir _ _) to@(_ :/ Dir {}) = moveDir from to
easyMove _ _ = return () easyMove _ _ = return ()
@ -292,16 +291,16 @@ easyMove _ _ = return ()
-- |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 FileInfo FileInfo -> IO () deleteSymlink :: AnchoredFile FileInfo -> IO ()
deleteSymlink f@(IsSymL True) deleteSymlink f@(_ :/ SymLink {})
= removeFile (fullPath f) = removeFile (fullPath f)
deleteSymlink _ deleteSymlink _
= return () = return ()
-- |Deletes the given file, never symlinks. -- |Deletes the given file, never symlinks.
deleteFile :: AnchoredFile FileInfo FileInfo -> IO () deleteFile :: AnchoredFile FileInfo -> IO ()
deleteFile (IsSymL True) = return () deleteFile (_ :/ SymLink {}) = return ()
deleteFile f@(_ :/ RegFile {}) deleteFile f@(_ :/ RegFile {})
= removeFile (fullPath f) = removeFile (fullPath f)
deleteFile _ deleteFile _
@ -309,16 +308,16 @@ deleteFile _
-- |Deletes the given directory, never symlinks. -- |Deletes the given directory, never symlinks.
deleteDir :: AnchoredFile FileInfo FileInfo -> IO () deleteDir :: AnchoredFile FileInfo -> IO ()
deleteDir (IsSymL True) = return () deleteDir (_ :/ SymLink {}) = return ()
deleteDir f@(_ :/ Dir {}) deleteDir f@(_ :/ Dir {})
= removeDirectory (fullPath f) = removeDirectory (fullPath f)
deleteDir _ = return () deleteDir _ = return ()
-- |Deletes the given directory recursively, never symlinks. -- |Deletes the given directory recursively, never symlinks.
deleteDirRecursive :: AnchoredFile FileInfo FileInfo -> IO () deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
deleteDirRecursive (IsSymL True) = return () deleteDirRecursive (_ :/ SymLink {}) = return ()
deleteDirRecursive f@(_ :/ Dir {}) deleteDirRecursive f@(_ :/ Dir {})
= removeDirectoryRecursive (fullPath f) = removeDirectoryRecursive (fullPath f)
deleteDirRecursive _ = return () deleteDirRecursive _ = return ()
@ -327,8 +326,8 @@ deleteDirRecursive _ = return ()
-- |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 FileInfo FileInfo -> IO () easyDelete :: AnchoredFile FileInfo -> IO ()
easyDelete f@(IsSymL True) = deleteSymlink f easyDelete f@(_ :/ SymLink {}) = deleteSymlink f
easyDelete f@(_ :/ RegFile {}) easyDelete f@(_ :/ RegFile {})
= deleteFile f = deleteFile f
easyDelete f@(_ :/ Dir {}) easyDelete f@(_ :/ Dir {})
@ -345,16 +344,15 @@ easyDelete _
-- |Opens a file appropriately by invoking xdg-open. -- |Opens a file appropriately by invoking xdg-open.
openFile :: AnchoredFile a b openFile :: AnchoredFile a
-> IO ProcessHandle -> IO ProcessHandle
openFile f = spawnProcess "xdg-open" [fullPath f] openFile f = spawnProcess "xdg-open" [fullPath f]
-- |Executes a program with the given arguments. -- |Executes a program with the given arguments.
executeFile :: AnchoredFile FileInfo FileInfo -- ^ program executeFile :: AnchoredFile FileInfo -- ^ program
-> [String] -- ^ arguments -> [String] -- ^ arguments
-> IO (Maybe ProcessHandle) -> IO (Maybe ProcessHandle)
executeFile prog@(_ :/ RegFile _ FileInfo { permissions = perms }) args executeFile prog@(_ :/ RegFile {}) args
| executable perms = Just <$> spawnProcess (fullPath prog) args = Just <$> spawnProcess (fullPath prog) args
| otherwise = return Nothing
executeFile _ _ = return Nothing executeFile _ _ = return Nothing