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

LIB/GTK: use our hpath lib for path type

Browse Source
This commit is contained in:
Julian Ospald 2016-03-30 02:50:32 +02:00
parent 09d8910eae
commit f301e2e519
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
7 changed files with 247 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitmodules vendored Normal file
View File

@ -0,0 +1,3 @@
[submodule "3rdparty/hpath"]
path = 3rdparty/hpath
url = https://github.com/hasufell/hpath.git

1
3rdparty/hpath vendored Submodule

@ -0,0 +1 @@
Subproject commit 3c3a2d276646f6530970f675ef32c6089c1e56d4

2
hsfm.cabal
View File

@ -36,6 +36,7 @@ library
hinotify, hinotify,
mtl >= 2.2, mtl >= 2.2,
old-locale >= 1, old-locale >= 1,
hpath,
process, process,
safe, safe,
stm, stm,
@ -75,6 +76,7 @@ executable hsfm-gtk
hinotify, hinotify,
mtl >= 2.2, mtl >= 2.2,
old-locale >= 1, old-locale >= 1,
hpath,
process, process,
safe, safe,
stm, stm,

276
src/Data/DirTree.hs
View File

@ -62,7 +62,8 @@ import Data.List
) )
import Data.Maybe import Data.Maybe
( (
fromMaybe catMaybes
, fromMaybe
) )
import Data.Ord import Data.Ord
( (
@ -85,6 +86,15 @@ import Data.Word
( (
Word64 Word64
) )
import HPath
(
Abs
, Path
, Fn
, Rel
, pattern Path
)
import qualified HPath as P
import Safe import Safe
( (
atDef atDef
@ -144,14 +154,10 @@ import qualified System.Posix.Directory as PFD
---------------------------- ----------------------------
-- |Weak type to distinguish between FilePath and FileName.
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 = data AnchoredFile a =
(:/) { anchor :: FilePath, file :: File a } (:/) { anchor :: Path Abs, file :: File a }
deriving (Eq, Show) deriving (Eq, Show)
@ -162,37 +168,39 @@ data AnchoredFile a =
-- 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 :: FileName name :: Path Fn
, err :: IOException , err :: IOException
} }
| Dir { | Dir {
name :: FileName name :: Path Fn
, fvar :: a , fvar :: a
} }
| RegFile { | RegFile {
name :: FileName name :: Path Fn
, fvar :: a , fvar :: a
} }
-- TODO: add raw symlink dest (not normalized) to SymLink?
| SymLink { | SymLink {
name :: FileName name :: Path Fn
, fvar :: a , fvar :: a
, sdest :: AnchoredFile a -- ^ symlink madness, , sdest :: AnchoredFile a -- ^ symlink madness,
-- we need to know where it points to -- we need to know where it points to
, rawdest :: FilePath
} }
| BlockDev { | BlockDev {
name :: FileName name :: Path Fn
, fvar :: a , fvar :: a
} }
| CharDev { | CharDev {
name :: FileName name :: Path Fn
, fvar :: a , fvar :: a
} }
| NamedPipe { | NamedPipe {
name :: FileName name :: Path Fn
, fvar :: a , fvar :: a
} }
| Socket { | Socket {
name :: FileName name :: Path Fn
, fvar :: a , fvar :: a
} deriving (Show, Eq) } deriving (Show, Eq)
@ -216,9 +224,9 @@ data FileInfo = FileInfo {
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
type UserIO a = FilePath -> IO a type UserIO a t = Path Abs -> IO a
type Builder a = UserIO a -> FilePath -> IO [File a] type Builder a t = UserIO a t -> Path Abs -> IO [File a]
@ -240,12 +248,12 @@ afileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
afileLike f@(bp :/ constr) = convertViewP fileLike f afileLike f@(bp :/ constr) = 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)
fileLike f@(CharDev {}) = (True, f) fileLike f@CharDev{} = (True, f)
fileLike f@(NamedPipe {}) = (True, f) fileLike f@NamedPipe{} = (True, f)
fileLike f@(Socket {}) = (True, f) fileLike f@Socket{} = (True, f)
fileLike f = (False, f) fileLike f = (False, f)
sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo) sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
@ -268,12 +276,12 @@ safileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
safileLike f = convertViewP sfileLike f 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)
sfileLike f@(CharDev {}) = (True, f) sfileLike f@CharDev{} = (True, f)
sfileLike f@(NamedPipe {}) = (True, f) sfileLike f@NamedPipe{} = (True, f)
sfileLike f@(Socket {}) = (True, f) sfileLike f@Socket{} = (True, f)
sfileLike f = fileLikeSym f sfileLike f = fileLikeSym f
afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo) afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
@ -304,11 +312,11 @@ dirSym f@(SymLink { sdest = (_ :/ Dir {} )}) = (True, f)
dirSym f = (False, f) dirSym f = (False, f)
invalidFileName :: FileName -> (Bool, FileName) invalidFileName :: Path Fn -> (Bool, Path Fn)
invalidFileName "" = (True, "") invalidFileName p@(Path "") = (True, p)
invalidFileName "." = (True, ".") invalidFileName p@(Path ".") = (True, p)
invalidFileName ".." = (True, "..") invalidFileName p@(Path "..") = (True, p)
invalidFileName fn = (elem pathSeparator fn, fn) invalidFileName p@(Path fn) = (elem pathSeparator fn, p)
abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo) abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
@ -408,72 +416,80 @@ instance Ord (AnchoredFile FileInfo) where
---------------------------- ----------------------------
-- |Read a file into an `AnchoredFile`, filling the free variables via -- |Reads a file or directory Path into an `AnchoredFile`, filling the free
-- the given function. -- variables via the given function.
readFileWith :: (FilePath -> IO a) readWith :: (Path Abs -> IO a) -- ^ function that fills the free
-> FilePath -- a variable
-> IO (AnchoredFile a) -> Path Abs -- ^ Path to read
readFileWith ff p = do -> IO (AnchoredFile a)
let fn = topDir p readWith ff p = do
bd = baseDir p let fn = P.basename p
handleDT' bd fn $ do bd = P.dirname p
fs <- PF.getSymbolicLinkStatus p p' = P.toFilePath p
fv <- ff p bd' <- P.canonicalizePath bd -- TODO: this will cause a dialog to pop up on error
file <- constructFile fs fv bd fn handleDT' bd' fn $ do
return (bd :/ file) fs <- PF.getSymbolicLinkStatus p'
fv <- ff p
file <- constructFile fs fv bd' fn
return (bd' :/ file)
where where
constructFile fs fv bd' n constructFile fs fv bd' fn'
| 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' </> n let fp = bd' P.</> fn'
resolvedSyml <- handleDT' bd' n $ do x <- PF.readSymbolicLink (P.fromAbs fp)
sfp <- (\x -> if isAbsolute x then x else bd' </> x) resolvedSyml <- handleDT' bd' fn' $ do
<$> PF.readSymbolicLink fp -- watch out, we call </> from 'filepath' here, but it is safe
_ <- PF.getFileStatus sfp -- important to break infinite symbolic -- TODO: could it happen that too many '..' lead
-- link cycle -- to something like '/' after normalization?
readFileWith ff sfp let sfp = if isAbsolute x then x else (P.fromAbs bd') </> x
return $ SymLink n fv resolvedSyml sf <- PF.getFileStatus sfp -- important to break infinite symbolic
| PF.isDirectory fs = return $ Dir n fv -- link cycle
| PF.isRegularFile fs = return $ RegFile n fv rsfp <- P.realPath sfp
| PF.isBlockDevice fs = return $ BlockDev n fv readWith ff =<< P.parseAbs rsfp
| PF.isCharacterDevice fs = return $ CharDev n fv return $ SymLink fn' fv resolvedSyml x
| PF.isNamedPipe fs = return $ NamedPipe n fv | PF.isDirectory fs = return $ Dir fn' fv
| PF.isSocket fs = return $ Socket n fv | PF.isRegularFile fs = return $ RegFile fn' fv
| otherwise = return $ Failed n (userError | PF.isBlockDevice fs = return $ BlockDev fn' fv
"Unknown filetype!") | 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!")
readFile :: FilePath -> IO (AnchoredFile FileInfo) -- |Reads a file Path into an AnchoredFile.
readFile fp = readFileWith getFileInfo $ normalize fp readFile :: (Path Abs -> IO a) -> Path Abs -> IO (AnchoredFile a)
readFile ff fp = readWith ff fp
readFileWithFileInfo :: Path Abs -> IO (AnchoredFile FileInfo)
readFileWithFileInfo = Data.DirTree.readFile getFileInfo
-- |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] readDirectoryContents :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo readDirectoryContents fp = readDirectoryContentsWith getAllDirsFiles getFileInfo fp
$ normalize 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] readDirectoryContents' :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo readDirectoryContents' fp = readDirectoryContentsWith getDirsFiles getFileInfo fp
$ normalize fp
-- | same as readDirectory but allows us to, for example, use -- |Same as readDirectoryContents 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]) readDirectoryContentsWith :: (Path Abs -> IO [Path Fn])
-> (FilePath -> IO a) -> (Path Abs -> IO a)
-> FilePath -> Path Abs
-> IO [AnchoredFile a] -> IO [AnchoredFile a]
readDirectoryWith getfiles ff p = do readDirectoryContentsWith getfiles ff p = do
contents <- getfiles $ normalize p files <- getfiles p
cs <- mapM (\x -> readFileWith ff $ p </> x) contents fcs <- mapM (\x -> Data.DirTree.readFile ff $ p P.</> x) files
return $ removeNonexistent cs return $ removeNonexistent fcs
@ -549,8 +565,8 @@ isDirC _ = False
isSymC :: File a -> Bool isSymC :: File a -> Bool
isSymC (SymLink _ _ _) = True isSymC (SymLink _ _ _ _) = True
isSymC _ = False isSymC _ = False
isBlockC :: File a -> Bool isBlockC :: File a -> Bool
@ -579,19 +595,11 @@ isSocketC _ = False
-- extracting pathnames and base names:
topDir, baseDir :: FilePath -> FilePath
topDir = last . splitDirectories
baseDir = joinPath . init . splitDirectories
-- |Check whether the given file is a hidden file. -- |Check whether the given file is a hidden file.
hiddenFile :: FilePath -> Bool hiddenFile :: Path Fn -> Bool
hiddenFile "." = False hiddenFile (Path ".") = False
hiddenFile ".." = False hiddenFile (Path "..") = False
hiddenFile str hiddenFile (Path fn) = "." `isPrefixOf` fn
| "." `isPrefixOf` str = True
| otherwise = False
-- |Like `normalise` from System.FilePath but removes occurences of '..'. -- |Like `normalise` from System.FilePath but removes occurences of '..'.
@ -612,29 +620,27 @@ normalize fp =
-- |Go up one directory in the filesystem hierarchy. -- |Go up one directory in the filesystem hierarchy.
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo) goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
goUp af@("" :/ _) = return af goUp af@(Path "" :/ _) = return af
goUp (bp :/ _) = Data.DirTree.readFile bp goUp (bp :/ _) = Data.DirTree.readFile getFileInfo bp
-- |Go up one directory in the filesystem hierarchy. -- |Go up one directory in the filesystem hierarchy.
goUp' :: FilePath -> IO (AnchoredFile FileInfo) goUp' :: Path Abs -> IO (AnchoredFile FileInfo)
goUp' fp = do goUp' fp = Data.DirTree.readFile getFileInfo $ P.dirname fp
let cfp = normalize fp
Data.DirTree.readFile $ baseDir cfp
-- |Get the contents of a directory. -- |Get the contents of a directory.
getContents :: AnchoredFile FileInfo getContents :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo] -> IO [AnchoredFile FileInfo]
getContents (ADirOrSym af) = readDirectory (fullPath af) getContents (ADirOrSym af) = readDirectoryContents (fullPath af)
getContents _ = return [] getContents _ = return []
getDirsFiles' :: (FilePath -> [FilePath] -> [FilePath]) getDirsFiles' :: (FilePath -> [FilePath] -> [FilePath])
-> FilePath -> Path Abs
-> IO [FilePath] -> IO [Path Fn]
getDirsFiles' filterf fp = do getDirsFiles' filterf fp = do
dirstream <- PFD.openDirStream fp dirstream <- PFD.openDirStream . P.toFilePath $ fp
let mdirs :: [FilePath] -> IO [FilePath] let mdirs :: [FilePath] -> IO [FilePath]
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
@ -645,18 +651,18 @@ getDirsFiles' filterf fp = do
else mdirs (dir `filterf` dirs) else mdirs (dir `filterf` dirs)
dirs <- mdirs [] dirs <- mdirs []
PFD.closeDirStream dirstream PFD.closeDirStream dirstream
return dirs return $ catMaybes (fmap P.parseFn dirs)
-- |Get all files of a given directory and return them as a List. -- |Get all files of a given directory and return them as a List.
-- This includes "." and "..". -- This includes "." and "..".
getAllDirsFiles :: FilePath -> IO [FilePath] getAllDirsFiles :: Path Abs -> IO [Path Fn]
getAllDirsFiles = getDirsFiles' (:) getAllDirsFiles = getDirsFiles' (:)
-- |Get all files of a given directory and return them as a List. -- |Get all files of a given directory and return them as a List.
-- This excludes "." and "..". -- This excludes "." and "..".
getDirsFiles :: FilePath -> IO [FilePath] getDirsFiles :: Path Abs -> IO [Path Fn]
getDirsFiles = getDirsFiles' insert getDirsFiles = getDirsFiles' insert
where where
insert dir dirs = case dir of insert dir dirs = case dir of
@ -666,9 +672,9 @@ getDirsFiles = getDirsFiles' insert
-- |Gets all file information. -- |Gets all file information.
getFileInfo :: FilePath -> IO FileInfo getFileInfo :: Path Abs -> IO FileInfo
getFileInfo fp = do getFileInfo fp = do
fs <- PF.getSymbolicLinkStatus fp fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
return $ FileInfo return $ FileInfo
(PF.deviceID fs) (PF.deviceID fs)
(PF.fileID fs) (PF.fileID fs)
@ -688,14 +694,14 @@ getFileInfo fp = do
-- |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 -> Maybe a getFreeVar :: File a -> Maybe a
getFreeVar (Dir _ d) = Just d getFreeVar (Dir _ d) = Just d
getFreeVar (RegFile _ d) = Just d getFreeVar (RegFile _ d) = Just d
getFreeVar (SymLink _ d _) = Just d getFreeVar (SymLink _ d _ _) = Just d
getFreeVar (BlockDev _ d) = Just d getFreeVar (BlockDev _ d) = Just d
getFreeVar (CharDev _ d) = Just d getFreeVar (CharDev _ d) = Just d
getFreeVar (NamedPipe _ d) = Just d getFreeVar (NamedPipe _ d) = Just d
getFreeVar (Socket _ d) = Just d getFreeVar (Socket _ d) = Just d
getFreeVar _ = Nothing getFreeVar _ = Nothing
---- FAILURE HELPERS: ---- ---- FAILURE HELPERS: ----
@ -703,14 +709,19 @@ 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) -> IO (File a) handleDT :: Path Fn -> 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 -- handles an IO exception by returning a Failed constructor filled with that
-- exception: -- exception:
handleDT' :: FilePath -> FileName -> IO (AnchoredFile a) -> IO (AnchoredFile a) -- TODO: only handle IO exceptions
handleDT' bp n = handle (\e -> return $ bp :/ Failed n e) handleDT' :: Path Abs
-> Path Fn
-> IO (AnchoredFile a)
-> IO (AnchoredFile a)
handleDT' bp n
= handle (\e -> return $ bp :/ Failed n e)
-- DoesNotExist errors not present at the topmost level could happen if a -- DoesNotExist errors not present at the topmost level could happen if a
@ -729,25 +740,12 @@ removeNonexistent = filter isOkConstructor
---- SYMLINK HELPERS: ---- ---- SYMLINK HELPERS: ----
-- |Follows a chain of symlinks until it finds a non-symlink. Note that
-- this can be caught in an infinite loop if the symlinks haven't been
-- constructed properly. This module however ensures that this cannot
-- happen.
followSymlink :: File FileInfo -> File FileInfo
followSymlink (SymLink _ _ (_ :/ b@(SymLink {}))) = followSymlink b
followSymlink af = af
-- |Checks if a symlink is broken by examining the constructor of the -- |Checks if a symlink is broken by examining the constructor of the
-- symlink destination. This also follows the symlink chain. -- symlink destination. This also follows the symlink chain.
-- --
-- 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 af@(SymLink _ _ (_ :/ Failed {})) = True isBrokenSymlink af@(SymLink _ _ (_ :/ Failed {}) _) = True
isBrokenSymlink af@(SymLink {})
= case followSymlink af of
(Failed {}) -> True
_ -> False
isBrokenSymlink _ = False isBrokenSymlink _ = False
@ -755,8 +753,8 @@ isBrokenSymlink _ = False
fullPath :: AnchoredFile a -> FilePath fullPath :: AnchoredFile a -> Path Abs
fullPath (bp :/ f) = bp </> name f fullPath (bp :/ f) = bp P.</> name f
-- |Apply a function on the free variable. If there is no free variable -- |Apply a function on the free variable. If there is no free variable

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

@ -53,6 +53,7 @@ import GUI.Gtk.Data
import GUI.Gtk.Dialogs import GUI.Gtk.Dialogs
import GUI.Gtk.MyView import GUI.Gtk.MyView
import GUI.Gtk.Utils import GUI.Gtk.Utils
import qualified HPath as P
import IO.Error import IO.Error
import IO.File import IO.File
import IO.Utils import IO.Utils
@ -216,7 +217,7 @@ open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $ open [item] mygui myview = withErrorDialog $
case item of case item of
ADirOrSym r -> do ADirOrSym r -> do
nv <- Data.DirTree.readFile $ fullPath r nv <- Data.DirTree.readFileWithFileInfo $ fullPath r
refreshView' mygui myview nv refreshView' mygui myview nv
r -> r ->
void $ openFile r void $ openFile r
@ -240,7 +241,7 @@ execute _ _ _ = withErrorDialog
-- |Supposed to be used with 'withRows'. Deletes a file or directory. -- |Supposed to be used with 'withRows'. Deletes a file or directory.
del :: [Item] -> MyGUI -> MyView -> IO () del :: [Item] -> MyGUI -> MyView -> IO ()
del [item] mygui myview = withErrorDialog $ do del [item] mygui myview = withErrorDialog $ do
let cmsg = "Really delete \"" ++ fullPath item ++ "\"?" let cmsg = "Really delete \"" ++ P.fromAbs (fullPath item) ++ "\"?"
withConfirmationDialog cmsg withConfirmationDialog cmsg
$ easyDelete item $ easyDelete item
-- this throws on the first error that occurs -- this throws on the first error that occurs
@ -257,7 +258,7 @@ del _ _ _ = withErrorDialog
moveInit :: [Item] -> MyGUI -> MyView -> IO () moveInit :: [Item] -> MyGUI -> MyView -> IO ()
moveInit [item] mygui myview = do moveInit [item] mygui myview = do
writeTVarIO (operationBuffer myview) (FMove . MP1 $ item) writeTVarIO (operationBuffer myview) (FMove . MP1 $ item)
let sbmsg = "Move buffer: " ++ fullPath item let sbmsg = "Move buffer: " ++ P.fromAbs (fullPath item)
popStatusbar mygui popStatusbar mygui
void $ pushStatusBar mygui sbmsg void $ pushStatusBar mygui sbmsg
moveInit _ _ _ = withErrorDialog moveInit _ _ _ = withErrorDialog
@ -268,7 +269,7 @@ moveInit _ _ _ = withErrorDialog
copyInit :: [Item] -> MyGUI -> MyView -> IO () copyInit :: [Item] -> MyGUI -> MyView -> IO ()
copyInit [item] mygui myview = do copyInit [item] mygui myview = do
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item) writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item)
let sbmsg = "Copy buffer: " ++ fullPath item let sbmsg = "Copy buffer: " ++ P.fromAbs (fullPath item)
popStatusbar mygui popStatusbar mygui
void $ pushStatusBar mygui sbmsg void $ pushStatusBar mygui sbmsg
copyInit _ _ _ = withErrorDialog copyInit _ _ _ = withErrorDialog
@ -283,14 +284,14 @@ operationFinal mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview cdir <- getCurrentDir myview
case op of case op of
FMove (MP1 s) -> do FMove (MP1 s) -> do
let cmsg = "Really move \"" ++ fullPath s let cmsg = "Really move \"" ++ P.fromAbs (fullPath s)
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?" ++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
withConfirmationDialog cmsg . withCopyModeDialog withConfirmationDialog cmsg . withCopyModeDialog
$ \cm -> void $ runFileOp (FMove . MC s cdir $ cm) $ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
return () return ()
FCopy (CP1 s) -> do FCopy (CP1 s) -> do
let cmsg = "Really copy \"" ++ fullPath s let cmsg = "Really copy \"" ++ P.fromAbs (fullPath s)
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?" ++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
withConfirmationDialog cmsg . withCopyModeDialog withConfirmationDialog cmsg . withCopyModeDialog
$ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm) $ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
return () return ()
@ -311,17 +312,19 @@ upDir mygui myview = withErrorDialog $ do
newFile :: MyGUI -> MyView -> IO () newFile :: MyGUI -> MyView -> IO ()
newFile mygui myview = withErrorDialog $ do newFile mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name" mfn <- textInputDialog "Enter file name"
for_ mfn $ \fn -> do let pmfn = P.parseFn =<< mfn
for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview cdir <- getCurrentDir myview
createFile cdir fn createFile cdir fn
renameF :: [Item] -> MyGUI -> MyView -> IO () renameF :: [Item] -> MyGUI -> MyView -> IO ()
renameF [item] mygui myview = withErrorDialog $ do renameF [item] mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter new file name" mfn <- textInputDialog "Enter new file name"
for_ mfn $ \fn -> do let pmfn = P.parseFn =<< mfn
let cmsg = "Really rename \"" ++ fullPath item for_ pmfn $ \fn -> do
++ "\"" ++ " to \"" ++ anchor item </> fn ++ "\"?" let cmsg = "Really rename \"" ++ P.fromAbs (fullPath item)
++ "\"" ++ " to \"" ++ P.fromAbs (anchor item P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $ IO.File.renameFile item fn withConfirmationDialog cmsg $ IO.File.renameFile item fn
renameF _ _ _ = withErrorDialog renameF _ _ _ = withErrorDialog
. throw $ InvalidOperation . throw $ InvalidOperation

47
src/GUI/Gtk/MyView.hs
View File

@ -44,11 +44,15 @@ import Data.Foldable
import Data.Maybe import Data.Maybe
( (
catMaybes catMaybes
, fromJust
, fromMaybe
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk
import {-# SOURCE #-} GUI.Gtk.Callbacks (setCallbacks) import {-# SOURCE #-} GUI.Gtk.Callbacks (setCallbacks)
import GUI.Gtk.Data import GUI.Gtk.Data
import GUI.Gtk.Icons
import GUI.Gtk.Utils import GUI.Gtk.Utils
import qualified HPath as P
import IO.File import IO.File
import IO.Utils import IO.Utils
import System.FilePath import System.FilePath
@ -127,6 +131,8 @@ createIconView = do
iconViewSetColumns iconv (-1) iconViewSetColumns iconv (-1)
iconViewSetSpacing iconv 2 iconViewSetSpacing iconv 2
iconViewSetMargin iconv 0 iconViewSetMargin iconv 0
{- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -}
{- set iconv [ iconViewOrientation := OrientationHorizontal ] -}
return $ FMIconView iconv return $ FMIconView iconv
@ -189,10 +195,9 @@ refreshView :: MyGUI
refreshView mygui myview mfp = refreshView mygui myview mfp =
case mfp of case mfp of
Just fp -> do Just fp -> do
cdir <- (\x -> if (failed . file $ x) || (not . isAbsolute . anchor $ x) let mdir = fromMaybe (fromJust $ P.parseAbs "/") (P.parseAbs fp)
then Data.DirTree.readFile "/" cdir <- Data.DirTree.readFileWithFileInfo mdir
else return x) =<< Data.DirTree.readFile fp refreshView' mygui myview cdir
refreshView' mygui myview cdir
Nothing -> refreshView' mygui myview =<< getCurrentDir myview Nothing -> refreshView' mygui myview =<< getCurrentDir myview
@ -233,12 +238,30 @@ constructView :: MyGUI
-> MyView -> MyView
-> IO () -> IO ()
constructView mygui myview = do constructView mygui myview = do
settings' <- readTVarIO $ settings mygui
-- pix stuff
iT <- iconThemeGetDefault
folderPix <- getIcon IFolder iT (iconSize settings')
folderSymPix <- getSymlinkIcon IFolder iT (iconSize settings')
filePix <- getIcon IFile iT (iconSize settings')
fileSymPix <- getSymlinkIcon IFile iT (iconSize settings')
errorPix <- getIcon IError iT (iconSize settings')
let dirtreePix (Dir {}) = folderPix
dirtreePix (FileLike {}) = filePix
dirtreePix (DirSym _) = folderSymPix
dirtreePix (FileLikeSym {}) = fileSymPix
dirtreePix (Failed {}) = errorPix
dirtreePix (BrokenSymlink _) = errorPix
dirtreePix _ = errorPix
view' <- readTVarIO $ view myview view' <- readTVarIO $ view myview
cdirp <- anchor <$> getFirstItem myview cdirp <- anchor <$> getFirstItem myview
-- update urlBar -- update urlBar
entrySetText (urlBar mygui) cdirp entrySetText (urlBar mygui) (P.fromAbs cdirp)
rawModel' <- readTVarIO $ rawModel myview rawModel' <- readTVarIO $ rawModel myview
@ -267,7 +290,7 @@ constructView mygui myview = do
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0) treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . file) (dirtreePix . file)
treeModelSetColumn rawModel' (makeColumnIdString 1) treeModelSetColumn rawModel' (makeColumnIdString 1)
(name . file) (P.fromRel . name . file)
treeModelSetColumn rawModel' (makeColumnIdString 2) treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . file) (packModTime . file)
treeModelSetColumn rawModel' (makeColumnIdString 3) treeModelSetColumn rawModel' (makeColumnIdString 3)
@ -292,16 +315,8 @@ constructView mygui myview = do
w <- addWatch w <- addWatch
newi newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf] [Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
cdirp (P.fromAbs cdirp)
(\_ -> postGUIAsync $ refreshView mygui myview (Just cdirp)) (\_ -> postGUIAsync $ refreshView mygui myview (Just $ P.fromAbs cdirp))
putMVar (inotify myview) newi putMVar (inotify myview) newi
return () return ()
where
dirtreePix (Dir {}) = folderPix mygui
dirtreePix (FileLike {}) = filePix mygui
dirtreePix (DirSym _) = folderSymPix mygui
dirtreePix (FileLikeSym {}) = fileSymPix mygui
dirtreePix (Failed {}) = errorPix mygui
dirtreePix (BrokenSymlink _) = errorPix mygui
dirtreePix _ = errorPix mygui

100
src/IO/File.hs
View File

@ -50,6 +50,12 @@ import Foreign.C.Error
( (
eXDEV eXDEV
) )
import HPath
(
Path
, Fn
)
import qualified HPath as P
import IO.Error import IO.Error
import IO.Utils import IO.Utils
import System.FilePath import System.FilePath
@ -172,15 +178,17 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
to@(_ :/ Dir {}) to@(_ :/ Dir {})
= do = do
let fromp = fullPath from let fromp = fullPath from
fromp' = P.toFilePath fromp
top = fullPath to top = fullPath to
destdirp = top </> fromn destdirp = top P.</> fromn
throwDestinationInSource fromp destdirp destdirp' = P.toFilePath destdirp
throwSameFile fromp destdirp throwDestinationInSource fromp' destdirp'
throwSameFile fromp' destdirp'
createDestdir destdirp fmode createDestdir destdirp fmode
destdir <- Data.DirTree.readFile destdirp destdir <- Data.DirTree.readFileWithFileInfo destdirp
contents <- readDirectory' (fullPath from) contents <- readDirectoryContents' (fullPath from)
for_ contents $ \f -> for_ contents $ \f ->
case f of case f of
@ -190,17 +198,19 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
_ -> return () _ -> return ()
where where
createDestdir destdir fmode = createDestdir destdir fmode =
case cm of let destdir' = P.toFilePath destdir
in case cm of
Merge -> Merge ->
unlessM (doesDirectoryExist destdir) unlessM (doesDirectoryExist destdir')
(createDirectory destdir fmode) (createDirectory destdir' fmode)
Strict -> do Strict -> do
throwDirDoesExist destdir throwDirDoesExist destdir'
createDirectory destdir fmode createDirectory destdir' fmode
Replace -> do Replace -> do
whenM (doesDirectoryExist destdir) whenM (doesDirectoryExist destdir')
(deleteDirRecursive =<< Data.DirTree.readFile destdir) (deleteDirRecursive =<< Data.DirTree.readFileWithFileInfo
createDirectory destdir fmode destdir)
createDirectory destdir' fmode
copyDir _ _ _ = throw $ InvalidOperation "wrong input type" copyDir _ _ _ = throw $ InvalidOperation "wrong input type"
@ -215,16 +225,16 @@ recreateSymlink _ _ AFileInvFN = throw InvalidFileName
recreateSymlink cm symf@(_ :/ SymLink {}) recreateSymlink cm symf@(_ :/ SymLink {})
symdest@(_ :/ Dir {}) symdest@(_ :/ Dir {})
= do = do
sympoint <- readSymbolicLink (fullPath symf) sympoint <- readSymbolicLink (P.fromAbs . fullPath $ symf)
let symname = fullPath symdest </> (name . file $ symf) let symname = fullPath symdest P.</> (name . file $ symf)
case cm of case cm of
Merge -> delOld symname Merge -> delOld symname
Replace -> delOld symname Replace -> delOld symname
_ -> return () _ -> return ()
createSymbolicLink sympoint symname createSymbolicLink sympoint (P.fromAbs symname)
where where
delOld symname = do delOld symname = do
f <- Data.DirTree.readFile symname f <- Data.DirTree.readFileWithFileInfo symname
unless (failed . file $ f) unless (failed . file $ f)
(easyDelete f) (easyDelete f)
recreateSymlink _ _ _ = throw $ InvalidOperation "wrong input type" recreateSymlink _ _ _ = throw $ InvalidOperation "wrong input type"
@ -253,8 +263,8 @@ overwriteFile _ AFileInvFN = throw InvalidFileName
overwriteFile from@(_ :/ RegFile {}) overwriteFile from@(_ :/ RegFile {})
to@(_ :/ RegFile {}) to@(_ :/ RegFile {})
= do = do
let from' = fullPath from let from' = P.fromAbs . fullPath $ from
to' = fullPath to to' = P.fromAbs . fullPath $ to
throwSameFile from' to' throwSameFile from' to'
copyFile' from' to' copyFile' from' to'
overwriteFile _ _ = throw $ InvalidOperation "wrong input type" overwriteFile _ _ = throw $ InvalidOperation "wrong input type"
@ -271,8 +281,8 @@ copyFileToDir _ _ AFileInvFN = throw InvalidFileName
copyFileToDir cm from@(_ :/ RegFile fn _) copyFileToDir cm from@(_ :/ RegFile fn _)
to@(_ :/ Dir {}) to@(_ :/ Dir {})
= do = do
let from' = fullPath from let from' = P.fromAbs . fullPath $ from
to' = fullPath to </> fn to' = P.fromAbs (fullPath to P.</> fn)
case cm of case cm of
Strict -> throwFileDoesExist to' Strict -> throwFileDoesExist to'
_ -> return () _ -> return ()
@ -310,7 +320,7 @@ easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
deleteSymlink :: AnchoredFile FileInfo -> IO () deleteSymlink :: AnchoredFile FileInfo -> IO ()
deleteSymlink AFileInvFN = throw InvalidFileName deleteSymlink AFileInvFN = throw InvalidFileName
deleteSymlink f@(_ :/ SymLink {}) deleteSymlink f@(_ :/ SymLink {})
= removeLink (fullPath f) = removeLink (P.toFilePath . fullPath $ f)
deleteSymlink _ = throw $ InvalidOperation "wrong input type" deleteSymlink _ = throw $ InvalidOperation "wrong input type"
@ -318,7 +328,7 @@ deleteSymlink _ = throw $ InvalidOperation "wrong input type"
deleteFile :: AnchoredFile FileInfo -> IO () deleteFile :: AnchoredFile FileInfo -> IO ()
deleteFile AFileInvFN = throw InvalidFileName deleteFile AFileInvFN = throw InvalidFileName
deleteFile f@(_ :/ RegFile {}) deleteFile f@(_ :/ RegFile {})
= removeLink (fullPath f) = removeLink (P.toFilePath . fullPath $ f)
deleteFile _ = throw $ InvalidOperation "wrong input type" deleteFile _ = throw $ InvalidOperation "wrong input type"
@ -326,23 +336,25 @@ deleteFile _ = throw $ InvalidOperation "wrong input type"
deleteDir :: AnchoredFile FileInfo -> IO () deleteDir :: AnchoredFile FileInfo -> IO ()
deleteDir AFileInvFN = throw InvalidFileName deleteDir AFileInvFN = throw InvalidFileName
deleteDir f@(_ :/ Dir {}) deleteDir f@(_ :/ Dir {})
= removeDirectory (fullPath f) = removeDirectory (P.toFilePath . fullPath $ f)
deleteDir _ = throw $ InvalidOperation "wrong input type" deleteDir _ = throw $ InvalidOperation "wrong input type"
-- TODO: check if we have permissions at all to remove the directory,
-- before we go recursively messing with it
-- |Deletes the given directory recursively. -- |Deletes the given directory recursively.
deleteDirRecursive :: AnchoredFile FileInfo -> IO () deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
deleteDirRecursive AFileInvFN = throw InvalidFileName deleteDirRecursive AFileInvFN = throw InvalidFileName
deleteDirRecursive f@(_ :/ Dir {}) = do deleteDirRecursive f@(_ :/ Dir {}) = do
let fp = fullPath f let fp = fullPath f
files <- readDirectory' fp files <- readDirectoryContents' fp
for_ files $ \file -> for_ files $ \file ->
case file of case file of
(_ :/ SymLink {}) -> deleteSymlink file (_ :/ SymLink {}) -> deleteSymlink file
(_ :/ Dir {}) -> deleteDirRecursive file (_ :/ Dir {}) -> deleteDirRecursive file
(_ :/ RegFile {}) -> removeLink (fullPath file) (_ :/ RegFile {}) -> removeLink (P.toFilePath . fullPath $ file)
_ -> throw $ FileDoesExist (fullPath file) _ -> throw $ FileDoesExist (P.toFilePath . fullPath $ file)
removeDirectory fp removeDirectory . P.toFilePath $ fp
deleteDirRecursive _ = throw $ InvalidOperation "wrong input type" deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"
@ -369,7 +381,7 @@ easyDelete _ = throw $ InvalidOperation "wrong input type"
openFile :: AnchoredFile a openFile :: AnchoredFile a
-> IO ProcessHandle -> IO ProcessHandle
openFile AFileInvFN = throw InvalidFileName openFile AFileInvFN = throw InvalidFileName
openFile f = spawnProcess "xdg-open" [fullPath f] openFile f = spawnProcess "xdg-open" [P.fromAbs . fullPath $ f]
-- |Executes a program with the given arguments. -- |Executes a program with the given arguments.
@ -378,7 +390,7 @@ executeFile :: AnchoredFile FileInfo -- ^ program
-> IO ProcessHandle -> IO ProcessHandle
executeFile AFileInvFN _ = throw InvalidFileName executeFile AFileInvFN _ = throw InvalidFileName
executeFile prog@(_ :/ RegFile {}) args executeFile prog@(_ :/ RegFile {}) args
= spawnProcess (fullPath prog) args = spawnProcess (P.fromAbs . fullPath $ prog) args
executeFile _ _ = throw $ InvalidOperation "wrong input type" executeFile _ _ = throw $ InvalidOperation "wrong input type"
@ -389,22 +401,22 @@ executeFile _ _ = throw $ InvalidOperation "wrong input type"
--------------------- ---------------------
createFile :: AnchoredFile FileInfo -> FileName -> IO () createFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
createFile AFileInvFN _ = throw InvalidFileName createFile AFileInvFN _ = throw InvalidFileName
createFile _ InvFN = throw InvalidFileName createFile _ InvFN = throw InvalidFileName
createFile (ADirOrSym td) (ValFN fn) = do createFile (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td </> fn let fullp = P.fromAbs (fullPath td P.</> fn)
throwFileDoesExist fullp throwFileDoesExist fullp
fd <- System.Posix.IO.createFile fullp newFilePerms fd <- System.Posix.IO.createFile fullp newFilePerms
closeFd fd closeFd fd
createFile _ _ = throw $ InvalidOperation "wrong input type" createFile _ _ = throw $ InvalidOperation "wrong input type"
createDir :: AnchoredFile FileInfo -> FileName -> IO () createDir :: AnchoredFile FileInfo -> Path Fn -> IO ()
createDir AFileInvFN _ = throw InvalidFileName createDir AFileInvFN _ = throw InvalidFileName
createDir _ InvFN = throw InvalidFileName createDir _ InvFN = throw InvalidFileName
createDir (ADirOrSym td) (ValFN fn) = do createDir (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td </> fn let fullp = P.fromAbs (fullPath td P.</> fn)
throwDirDoesExist fullp throwDirDoesExist fullp
createDirectory fullp newFilePerms createDirectory fullp newFilePerms
createDir _ _ = throw $ InvalidOperation "wrong input type" createDir _ _ = throw $ InvalidOperation "wrong input type"
@ -417,12 +429,12 @@ createDir _ _ = throw $ InvalidOperation "wrong input type"
---------------------------- ----------------------------
renameFile :: AnchoredFile FileInfo -> FileName -> IO () renameFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
renameFile AFileInvFN _ = throw InvalidFileName renameFile AFileInvFN _ = throw InvalidFileName
renameFile _ InvFN = throw InvalidFileName renameFile _ InvFN = throw InvalidFileName
renameFile af (ValFN fn) = do renameFile af (ValFN fn) = do
let fromf = fullPath af let fromf = P.fromAbs . fullPath $ af
tof = anchor af </> fn tof = P.fromAbs (anchor af P.</> fn)
throwFileDoesExist tof throwFileDoesExist tof
throwSameFile fromf tof throwSameFile fromf tof
rename fromf tof rename fromf tof
@ -437,19 +449,21 @@ moveFile :: CopyMode
moveFile _ AFileInvFN _ = throw InvalidFileName moveFile _ AFileInvFN _ = throw InvalidFileName
moveFile _ _ AFileInvFN = throw InvalidFileName moveFile _ _ AFileInvFN = throw InvalidFileName
moveFile cm from to@(_ :/ Dir {}) = do moveFile cm from to@(_ :/ Dir {}) = do
let from' = fullPath from let from' = fullPath from
to' = fullPath to </> (name . file $ from) froms' = P.fromAbs . fullPath $ from
to' = fullPath to P.</> (name . file $ from)
tos' = P.fromAbs (fullPath to P.</> (name . file $ from))
case cm of case cm of
Strict -> throwFileDoesExist to' Strict -> throwFileDoesExist tos'
Merge -> delOld to' Merge -> delOld to'
Replace -> delOld to' Replace -> delOld to'
throwSameFile from' to' throwSameFile froms' tos'
catchErrno eXDEV (rename from' to') $ do catchErrno eXDEV (rename froms' tos') $ do
easyCopy Strict from to easyCopy Strict from to
easyDelete from easyDelete from
where where
delOld to = do delOld to = do
to' <- Data.DirTree.readFile to to' <- Data.DirTree.readFileWithFileInfo to
unless (failed . file $ to') (easyDelete to') unless (failed . file $ to') (easyDelete to')
moveFile _ _ _ = throw $ InvalidOperation "wrong input type" moveFile _ _ _ = throw $ InvalidOperation "wrong input type"