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,
mtl >= 2.2,
old-locale >= 1,
hpath,
process,
safe,
stm,
@ -75,6 +76,7 @@ executable hsfm-gtk
hinotify,
mtl >= 2.2,
old-locale >= 1,
hpath,
process,
safe,
stm,

276
src/Data/DirTree.hs
View File

@ -62,7 +62,8 @@ import Data.List
)
import Data.Maybe
(
fromMaybe
catMaybes
, fromMaybe
)
import Data.Ord
(
@ -85,6 +86,15 @@ import Data.Word
(
Word64
)
import HPath
(
Abs
, Path
, Fn
, Rel
, pattern Path
)
import qualified HPath as P
import Safe
(
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
-- to that file without the filename.
data AnchoredFile a =
(:/) { anchor :: FilePath, file :: File a }
(:/) { anchor :: Path Abs, file :: File a }
deriving (Eq, Show)
@ -162,37 +168,39 @@ data AnchoredFile a =
-- can be converted to a String with 'show'.
data File a =
Failed {
name :: FileName
name :: Path Fn
, err :: IOException
}
| Dir {
name :: FileName
name :: Path Fn
, fvar :: a
}
| RegFile {
name :: FileName
name :: Path Fn
, fvar :: a
}
-- TODO: add raw symlink dest (not normalized) to SymLink?
| SymLink {
name :: FileName
, fvar :: a
, sdest :: AnchoredFile a -- ^ symlink madness,
-- we need to know where it points to
name :: Path Fn
, fvar :: a
, sdest :: AnchoredFile a -- ^ symlink madness,
-- we need to know where it points to
, rawdest :: FilePath
}
| BlockDev {
name :: FileName
name :: Path Fn
, fvar :: a
}
| CharDev {
name :: FileName
name :: Path Fn
, fvar :: a
}
| NamedPipe {
name :: FileName
name :: Path Fn
, fvar :: a
}
| Socket {
name :: FileName
name :: Path Fn
, fvar :: a
} deriving (Show, Eq)
@ -216,9 +224,9 @@ data FileInfo = FileInfo {
} 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
fileLike :: File FileInfo -> (Bool, File FileInfo)
fileLike f@(RegFile {}) = (True, f)
fileLike f@(BlockDev {}) = (True, f)
fileLike f@(CharDev {}) = (True, f)
fileLike f@(NamedPipe {}) = (True, f)
fileLike f@(Socket {}) = (True, f)
fileLike f = (False, f)
fileLike f@RegFile {} = (True, f)
fileLike f@BlockDev{} = (True, f)
fileLike f@CharDev{} = (True, f)
fileLike f@NamedPipe{} = (True, f)
fileLike f@Socket{} = (True, f)
fileLike f = (False, f)
sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
@ -268,12 +276,12 @@ safileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
safileLike f = convertViewP sfileLike f
sfileLike :: File FileInfo -> (Bool, File FileInfo)
sfileLike f@(RegFile {}) = (True, f)
sfileLike f@(BlockDev {}) = (True, f)
sfileLike f@(CharDev {}) = (True, f)
sfileLike f@(NamedPipe {}) = (True, f)
sfileLike f@(Socket {}) = (True, f)
sfileLike f = fileLikeSym f
sfileLike f@RegFile{} = (True, f)
sfileLike f@BlockDev{} = (True, f)
sfileLike f@CharDev{} = (True, f)
sfileLike f@NamedPipe{} = (True, f)
sfileLike f@Socket{} = (True, f)
sfileLike f = fileLikeSym f
afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
@ -304,11 +312,11 @@ dirSym f@(SymLink { sdest = (_ :/ Dir {} )}) = (True, f)
dirSym f = (False, f)
invalidFileName :: FileName -> (Bool, FileName)
invalidFileName "" = (True, "")
invalidFileName "." = (True, ".")
invalidFileName ".." = (True, "..")
invalidFileName fn = (elem pathSeparator fn, fn)
invalidFileName :: Path Fn -> (Bool, Path Fn)
invalidFileName p@(Path "") = (True, p)
invalidFileName p@(Path ".") = (True, p)
invalidFileName p@(Path "..") = (True, p)
invalidFileName p@(Path fn) = (elem pathSeparator fn, p)
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
-- the given function.
readFileWith :: (FilePath -> IO a)
-> FilePath
-> IO (AnchoredFile a)
readFileWith ff p = do
let fn = topDir p
bd = baseDir p
handleDT' bd fn $ do
fs <- PF.getSymbolicLinkStatus p
fv <- ff p
file <- constructFile fs fv bd fn
return (bd :/ file)
-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
-- variables via the given function.
readWith :: (Path Abs -> IO a) -- ^ function that fills the free
-- a variable
-> Path Abs -- ^ Path to read
-> IO (AnchoredFile a)
readWith ff p = do
let fn = P.basename p
bd = P.dirname p
p' = P.toFilePath p
bd' <- P.canonicalizePath bd -- TODO: this will cause a dialog to pop up on error
handleDT' bd' fn $ do
fs <- PF.getSymbolicLinkStatus p'
fv <- ff p
file <- constructFile fs fv bd' fn
return (bd' :/ file)
where
constructFile fs fv bd' n
constructFile fs fv bd' fn'
| 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!")
let fp = bd' P.</> fn'
x <- PF.readSymbolicLink (P.fromAbs fp)
resolvedSyml <- handleDT' bd' fn' $ do
-- watch out, we call </> from 'filepath' here, but it is safe
-- TODO: could it happen that too many '..' lead
-- to something like '/' after normalization?
let sfp = if isAbsolute x then x else (P.fromAbs bd') </> x
sf <- PF.getFileStatus sfp -- important to break infinite symbolic
-- link cycle
rsfp <- P.realPath sfp
readWith ff =<< P.parseAbs rsfp
return $ SymLink fn' fv resolvedSyml x
| PF.isDirectory fs = return $ Dir fn' fv
| PF.isRegularFile fs = return $ RegFile fn' fv
| PF.isBlockDevice fs = return $ BlockDev fn' fv
| PF.isCharacterDevice fs = return $ CharDev fn' fv
| PF.isNamedPipe fs = return $ NamedPipe fn' fv
| PF.isSocket fs = return $ Socket fn' fv
| otherwise = return $ Failed fn' (userError
"Unknown filetype!")
readFile :: FilePath -> IO (AnchoredFile FileInfo)
readFile fp = readFileWith getFileInfo $ normalize fp
-- |Reads a file Path into an AnchoredFile.
readFile :: (Path Abs -> IO a) -> Path Abs -> IO (AnchoredFile a)
readFile ff fp = readWith ff fp
readFileWithFileInfo :: Path Abs -> IO (AnchoredFile FileInfo)
readFileWithFileInfo = Data.DirTree.readFile getFileInfo
-- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This includes the "." and ".."
-- directories.
readDirectory :: FilePath -> IO [AnchoredFile FileInfo]
readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo
$ normalize fp
readDirectoryContents :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectoryContents fp = readDirectoryContentsWith getAllDirsFiles getFileInfo fp
-- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This excludes the "." and ".."
-- directories.
readDirectory' :: FilePath -> IO [AnchoredFile FileInfo]
readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo
$ normalize fp
readDirectoryContents' :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectoryContents' fp = readDirectoryContentsWith getDirsFiles getFileInfo 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.
readDirectoryWith :: (FilePath -> IO [FilePath])
-> (FilePath -> IO a)
-> FilePath
-> IO [AnchoredFile a]
readDirectoryWith getfiles ff p = do
contents <- getfiles $ normalize p
cs <- mapM (\x -> readFileWith ff $ p </> x) contents
return $ removeNonexistent cs
readDirectoryContentsWith :: (Path Abs -> IO [Path Fn])
-> (Path Abs -> IO a)
-> Path Abs
-> IO [AnchoredFile a]
readDirectoryContentsWith getfiles ff p = do
files <- getfiles p
fcs <- mapM (\x -> Data.DirTree.readFile ff $ p P.</> x) files
return $ removeNonexistent fcs
@ -549,8 +565,8 @@ isDirC _ = False
isSymC :: File a -> Bool
isSymC (SymLink _ _ _) = True
isSymC _ = False
isSymC (SymLink _ _ _ _) = True
isSymC _ = False
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.
hiddenFile :: FilePath -> Bool
hiddenFile "." = False
hiddenFile ".." = False
hiddenFile str
| "." `isPrefixOf` str = True
| otherwise = False
hiddenFile :: Path Fn -> Bool
hiddenFile (Path ".") = False
hiddenFile (Path "..") = False
hiddenFile (Path fn) = "." `isPrefixOf` fn
-- |Like `normalise` from System.FilePath but removes occurences of '..'.
@ -612,29 +620,27 @@ normalize fp =
-- |Go up one directory in the filesystem hierarchy.
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
goUp af@("" :/ _) = return af
goUp (bp :/ _) = Data.DirTree.readFile bp
goUp af@(Path "" :/ _) = return af
goUp (bp :/ _) = Data.DirTree.readFile getFileInfo bp
-- |Go up one directory in the filesystem hierarchy.
goUp' :: FilePath -> IO (AnchoredFile FileInfo)
goUp' fp = do
let cfp = normalize fp
Data.DirTree.readFile $ baseDir cfp
goUp' :: Path Abs -> IO (AnchoredFile FileInfo)
goUp' fp = Data.DirTree.readFile getFileInfo $ P.dirname fp
-- |Get the contents of a directory.
getContents :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo]
getContents (ADirOrSym af) = readDirectory (fullPath af)
getContents (ADirOrSym af) = readDirectoryContents (fullPath af)
getContents _ = return []
getDirsFiles' :: (FilePath -> [FilePath] -> [FilePath])
-> FilePath
-> IO [FilePath]
-> Path Abs
-> IO [Path Fn]
getDirsFiles' filterf fp = do
dirstream <- PFD.openDirStream fp
dirstream <- PFD.openDirStream . P.toFilePath $ fp
let mdirs :: [FilePath] -> IO [FilePath]
mdirs dirs = do
-- make sure we close the directory stream in case of errors
@ -645,18 +651,18 @@ getDirsFiles' filterf fp = do
else mdirs (dir `filterf` dirs)
dirs <- mdirs []
PFD.closeDirStream dirstream
return dirs
return $ catMaybes (fmap P.parseFn dirs)
-- |Get all files of a given directory and return them as a List.
-- This includes "." and "..".
getAllDirsFiles :: FilePath -> IO [FilePath]
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 :: FilePath -> IO [FilePath]
getDirsFiles :: Path Abs -> IO [Path Fn]
getDirsFiles = getDirsFiles' insert
where
insert dir dirs = case dir of
@ -666,9 +672,9 @@ getDirsFiles = getDirsFiles' insert
-- |Gets all file information.
getFileInfo :: FilePath -> IO FileInfo
getFileInfo :: Path Abs -> IO FileInfo
getFileInfo fp = do
fs <- PF.getSymbolicLinkStatus fp
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
return $ FileInfo
(PF.deviceID fs)
(PF.fileID fs)
@ -688,14 +694,14 @@ getFileInfo fp = do
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
getFreeVar :: File a -> Maybe a
getFreeVar (Dir _ d) = Just d
getFreeVar (RegFile _ d) = Just d
getFreeVar (SymLink _ d _) = Just d
getFreeVar (BlockDev _ d) = Just d
getFreeVar (CharDev _ d) = Just d
getFreeVar (NamedPipe _ d) = Just d
getFreeVar (Socket _ d) = Just d
getFreeVar _ = Nothing
getFreeVar (Dir _ d) = Just d
getFreeVar (RegFile _ d) = Just d
getFreeVar (SymLink _ d _ _) = Just d
getFreeVar (BlockDev _ d) = Just d
getFreeVar (CharDev _ d) = Just d
getFreeVar (NamedPipe _ d) = Just d
getFreeVar (Socket _ d) = Just d
getFreeVar _ = Nothing
---- FAILURE HELPERS: ----
@ -703,14 +709,19 @@ getFreeVar _ = Nothing
-- handles an IO exception by returning a Failed constructor filled with that
-- exception:
handleDT :: FileName -> IO (File a) -> IO (File a)
handleDT :: Path Fn -> IO (File a) -> IO (File a)
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)
-- TODO: only handle IO exceptions
handleDT' :: Path Abs
-> Path Fn
-> IO (AnchoredFile a)
-> IO (AnchoredFile a)
handleDT' bp n
= handle (\e -> return $ bp :/ Failed n e)
-- DoesNotExist errors not present at the topmost level could happen if a
@ -729,25 +740,12 @@ removeNonexistent = filter isOkConstructor
---- 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
-- symlink destination. This also follows the symlink chain.
--
-- When called on a non-symlink, returns False.
isBrokenSymlink :: File FileInfo -> Bool
isBrokenSymlink af@(SymLink _ _ (_ :/ Failed {})) = True
isBrokenSymlink af@(SymLink {})
= case followSymlink af of
(Failed {}) -> True
_ -> False
isBrokenSymlink af@(SymLink _ _ (_ :/ Failed {}) _) = True
isBrokenSymlink _ = False
@ -755,8 +753,8 @@ isBrokenSymlink _ = False
fullPath :: AnchoredFile a -> FilePath
fullPath (bp :/ f) = bp </> name f
fullPath :: AnchoredFile a -> Path Abs
fullPath (bp :/ f) = bp P.</> name f
-- |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.MyView
import GUI.Gtk.Utils
import qualified HPath as P
import IO.Error
import IO.File
import IO.Utils
@ -216,7 +217,7 @@ open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
ADirOrSym r -> do
nv <- Data.DirTree.readFile $ fullPath r
nv <- Data.DirTree.readFileWithFileInfo $ fullPath r
refreshView' mygui myview nv
r ->
void $ openFile r
@ -240,7 +241,7 @@ execute _ _ _ = withErrorDialog
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
del :: [Item] -> MyGUI -> MyView -> IO ()
del [item] mygui myview = withErrorDialog $ do
let cmsg = "Really delete \"" ++ fullPath item ++ "\"?"
let cmsg = "Really delete \"" ++ P.fromAbs (fullPath item) ++ "\"?"
withConfirmationDialog cmsg
$ easyDelete item
-- this throws on the first error that occurs
@ -257,7 +258,7 @@ del _ _ _ = withErrorDialog
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
moveInit [item] mygui myview = do
writeTVarIO (operationBuffer myview) (FMove . MP1 $ item)
let sbmsg = "Move buffer: " ++ fullPath item
let sbmsg = "Move buffer: " ++ P.fromAbs (fullPath item)
popStatusbar mygui
void $ pushStatusBar mygui sbmsg
moveInit _ _ _ = withErrorDialog
@ -268,7 +269,7 @@ moveInit _ _ _ = withErrorDialog
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
copyInit [item] mygui myview = do
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item)
let sbmsg = "Copy buffer: " ++ fullPath item
let sbmsg = "Copy buffer: " ++ P.fromAbs (fullPath item)
popStatusbar mygui
void $ pushStatusBar mygui sbmsg
copyInit _ _ _ = withErrorDialog
@ -283,14 +284,14 @@ operationFinal mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
case op of
FMove (MP1 s) -> do
let cmsg = "Really move \"" ++ fullPath s
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
let cmsg = "Really move \"" ++ P.fromAbs (fullPath s)
++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
withConfirmationDialog cmsg . withCopyModeDialog
$ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
return ()
FCopy (CP1 s) -> do
let cmsg = "Really copy \"" ++ fullPath s
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
let cmsg = "Really copy \"" ++ P.fromAbs (fullPath s)
++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
withConfirmationDialog cmsg . withCopyModeDialog
$ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
return ()
@ -311,17 +312,19 @@ upDir mygui myview = withErrorDialog $ do
newFile :: MyGUI -> MyView -> IO ()
newFile mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name"
for_ mfn $ \fn -> do
let pmfn = P.parseFn =<< mfn
for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview
createFile cdir fn
renameF :: [Item] -> MyGUI -> MyView -> IO ()
renameF [item] mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter new file name"
for_ mfn $ \fn -> do
let cmsg = "Really rename \"" ++ fullPath item
++ "\"" ++ " to \"" ++ anchor item </> fn ++ "\"?"
mfn <- textInputDialog "Enter new file name"
let pmfn = P.parseFn =<< mfn
for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ P.fromAbs (fullPath item)
++ "\"" ++ " to \"" ++ P.fromAbs (anchor item P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $ IO.File.renameFile item fn
renameF _ _ _ = withErrorDialog
. throw $ InvalidOperation

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

@ -44,11 +44,15 @@ import Data.Foldable
import Data.Maybe
(
catMaybes
, fromJust
, fromMaybe
)
import Graphics.UI.Gtk
import {-# SOURCE #-} GUI.Gtk.Callbacks (setCallbacks)
import GUI.Gtk.Data
import GUI.Gtk.Icons
import GUI.Gtk.Utils
import qualified HPath as P
import IO.File
import IO.Utils
import System.FilePath
@ -127,6 +131,8 @@ createIconView = do
iconViewSetColumns iconv (-1)
iconViewSetSpacing iconv 2
iconViewSetMargin iconv 0
{- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -}
{- set iconv [ iconViewOrientation := OrientationHorizontal ] -}
return $ FMIconView iconv
@ -189,10 +195,9 @@ refreshView :: MyGUI
refreshView mygui myview mfp =
case mfp of
Just fp -> do
cdir <- (\x -> if (failed . file $ x) || (not . isAbsolute . anchor $ x)
then Data.DirTree.readFile "/"
else return x) =<< Data.DirTree.readFile fp
refreshView' mygui myview cdir
let mdir = fromMaybe (fromJust $ P.parseAbs "/") (P.parseAbs fp)
cdir <- Data.DirTree.readFileWithFileInfo mdir
refreshView' mygui myview cdir
Nothing -> refreshView' mygui myview =<< getCurrentDir myview
@ -233,12 +238,30 @@ constructView :: MyGUI
-> MyView
-> IO ()
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
cdirp <- anchor <$> getFirstItem myview
-- update urlBar
entrySetText (urlBar mygui) cdirp
entrySetText (urlBar mygui) (P.fromAbs cdirp)
rawModel' <- readTVarIO $ rawModel myview
@ -267,7 +290,7 @@ constructView mygui myview = do
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . file)
treeModelSetColumn rawModel' (makeColumnIdString 1)
(name . file)
(P.fromRel . name . file)
treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . file)
treeModelSetColumn rawModel' (makeColumnIdString 3)
@ -292,16 +315,8 @@ constructView mygui myview = do
w <- addWatch
newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
cdirp
(\_ -> postGUIAsync $ refreshView mygui myview (Just cdirp))
(P.fromAbs cdirp)
(\_ -> postGUIAsync $ refreshView mygui myview (Just $ P.fromAbs cdirp))
putMVar (inotify myview) newi
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
)
import HPath
(
Path
, Fn
)
import qualified HPath as P
import IO.Error
import IO.Utils
import System.FilePath
@ -172,15 +178,17 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
to@(_ :/ Dir {})
= do
let fromp = fullPath from
fromp' = P.toFilePath fromp
top = fullPath to
destdirp = top </> fromn
throwDestinationInSource fromp destdirp
throwSameFile fromp destdirp
destdirp = top P.</> fromn
destdirp' = P.toFilePath destdirp
throwDestinationInSource fromp' destdirp'
throwSameFile fromp' destdirp'
createDestdir destdirp fmode
destdir <- Data.DirTree.readFile destdirp
destdir <- Data.DirTree.readFileWithFileInfo destdirp
contents <- readDirectory' (fullPath from)
contents <- readDirectoryContents' (fullPath from)
for_ contents $ \f ->
case f of
@ -190,17 +198,19 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
_ -> return ()
where
createDestdir destdir fmode =
case cm of
let destdir' = P.toFilePath destdir
in case cm of
Merge ->
unlessM (doesDirectoryExist destdir)
(createDirectory destdir fmode)
unlessM (doesDirectoryExist destdir')
(createDirectory destdir' fmode)
Strict -> do
throwDirDoesExist destdir
createDirectory destdir fmode
throwDirDoesExist destdir'
createDirectory destdir' fmode
Replace -> do
whenM (doesDirectoryExist destdir)
(deleteDirRecursive =<< Data.DirTree.readFile destdir)
createDirectory destdir fmode
whenM (doesDirectoryExist destdir')
(deleteDirRecursive =<< Data.DirTree.readFileWithFileInfo
destdir)
createDirectory destdir' fmode
copyDir _ _ _ = throw $ InvalidOperation "wrong input type"
@ -215,16 +225,16 @@ recreateSymlink _ _ AFileInvFN = throw InvalidFileName
recreateSymlink cm symf@(_ :/ SymLink {})
symdest@(_ :/ Dir {})
= do
sympoint <- readSymbolicLink (fullPath symf)
let symname = fullPath symdest </> (name . file $ symf)
sympoint <- readSymbolicLink (P.fromAbs . fullPath $ symf)
let symname = fullPath symdest P.</> (name . file $ symf)
case cm of
Merge -> delOld symname
Replace -> delOld symname
_ -> return ()
createSymbolicLink sympoint symname
createSymbolicLink sympoint (P.fromAbs symname)
where
delOld symname = do
f <- Data.DirTree.readFile symname
f <- Data.DirTree.readFileWithFileInfo symname
unless (failed . file $ f)
(easyDelete f)
recreateSymlink _ _ _ = throw $ InvalidOperation "wrong input type"
@ -253,8 +263,8 @@ overwriteFile _ AFileInvFN = throw InvalidFileName
overwriteFile from@(_ :/ RegFile {})
to@(_ :/ RegFile {})
= do
let from' = fullPath from
to' = fullPath to
let from' = P.fromAbs . fullPath $ from
to' = P.fromAbs . fullPath $ to
throwSameFile from' to'
copyFile' from' to'
overwriteFile _ _ = throw $ InvalidOperation "wrong input type"
@ -271,8 +281,8 @@ copyFileToDir _ _ AFileInvFN = throw InvalidFileName
copyFileToDir cm from@(_ :/ RegFile fn _)
to@(_ :/ Dir {})
= do
let from' = fullPath from
to' = fullPath to </> fn
let from' = P.fromAbs . fullPath $ from
to' = P.fromAbs (fullPath to P.</> fn)
case cm of
Strict -> throwFileDoesExist to'
_ -> return ()
@ -310,7 +320,7 @@ easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
deleteSymlink :: AnchoredFile FileInfo -> IO ()
deleteSymlink AFileInvFN = throw InvalidFileName
deleteSymlink f@(_ :/ SymLink {})
= removeLink (fullPath f)
= removeLink (P.toFilePath . fullPath $ f)
deleteSymlink _ = throw $ InvalidOperation "wrong input type"
@ -318,7 +328,7 @@ deleteSymlink _ = throw $ InvalidOperation "wrong input type"
deleteFile :: AnchoredFile FileInfo -> IO ()
deleteFile AFileInvFN = throw InvalidFileName
deleteFile f@(_ :/ RegFile {})
= removeLink (fullPath f)
= removeLink (P.toFilePath . fullPath $ f)
deleteFile _ = throw $ InvalidOperation "wrong input type"
@ -326,23 +336,25 @@ deleteFile _ = throw $ InvalidOperation "wrong input type"
deleteDir :: AnchoredFile FileInfo -> IO ()
deleteDir AFileInvFN = throw InvalidFileName
deleteDir f@(_ :/ Dir {})
= removeDirectory (fullPath f)
= removeDirectory (P.toFilePath . fullPath $ f)
deleteDir _ = throw $ InvalidOperation "wrong input type"
-- TODO: check if we have permissions at all to remove the directory,
-- before we go recursively messing with it
-- |Deletes the given directory recursively.
deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
deleteDirRecursive AFileInvFN = throw InvalidFileName
deleteDirRecursive f@(_ :/ Dir {}) = do
let fp = fullPath f
files <- readDirectory' fp
files <- readDirectoryContents' fp
for_ files $ \file ->
case file of
(_ :/ SymLink {}) -> deleteSymlink file
(_ :/ Dir {}) -> deleteDirRecursive file
(_ :/ RegFile {}) -> removeLink (fullPath file)
_ -> throw $ FileDoesExist (fullPath file)
removeDirectory fp
(_ :/ RegFile {}) -> removeLink (P.toFilePath . fullPath $ file)
_ -> throw $ FileDoesExist (P.toFilePath . fullPath $ file)
removeDirectory . P.toFilePath $ fp
deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"
@ -369,7 +381,7 @@ easyDelete _ = throw $ InvalidOperation "wrong input type"
openFile :: AnchoredFile a
-> IO ProcessHandle
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.
@ -378,7 +390,7 @@ executeFile :: AnchoredFile FileInfo -- ^ program
-> IO ProcessHandle
executeFile AFileInvFN _ = throw InvalidFileName
executeFile prog@(_ :/ RegFile {}) args
= spawnProcess (fullPath prog) args
= spawnProcess (P.fromAbs . fullPath $ prog) args
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 _ InvFN = throw InvalidFileName
createFile (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td </> fn
let fullp = P.fromAbs (fullPath td P.</> fn)
throwFileDoesExist fullp
fd <- System.Posix.IO.createFile fullp newFilePerms
closeFd fd
createFile _ _ = throw $ InvalidOperation "wrong input type"
createDir :: AnchoredFile FileInfo -> FileName -> IO ()
createDir :: AnchoredFile FileInfo -> Path Fn -> IO ()
createDir AFileInvFN _ = throw InvalidFileName
createDir _ InvFN = throw InvalidFileName
createDir (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td </> fn
let fullp = P.fromAbs (fullPath td P.</> fn)
throwDirDoesExist fullp
createDirectory fullp newFilePerms
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 _ InvFN = throw InvalidFileName
renameFile af (ValFN fn) = do
let fromf = fullPath af
tof = anchor af </> fn
let fromf = P.fromAbs . fullPath $ af
tof = P.fromAbs (anchor af P.</> fn)
throwFileDoesExist tof
throwSameFile fromf tof
rename fromf tof
@ -437,19 +449,21 @@ moveFile :: CopyMode
moveFile _ AFileInvFN _ = throw InvalidFileName
moveFile _ _ AFileInvFN = throw InvalidFileName
moveFile cm from to@(_ :/ Dir {}) = do
let from' = fullPath from
to' = fullPath to </> (name . file $ from)
let from' = fullPath from
froms' = P.fromAbs . fullPath $ from
to' = fullPath to P.</> (name . file $ from)
tos' = P.fromAbs (fullPath to P.</> (name . file $ from))
case cm of
Strict -> throwFileDoesExist to'
Strict -> throwFileDoesExist tos'
Merge -> delOld to'
Replace -> delOld to'
throwSameFile from' to'
catchErrno eXDEV (rename from' to') $ do
throwSameFile froms' tos'
catchErrno eXDEV (rename froms' tos') $ do
easyCopy Strict from to
easyDelete from
where
delOld to = do
to' <- Data.DirTree.readFile to
to' <- Data.DirTree.readFileWithFileInfo to
unless (failed . file $ to') (easyDelete to')
moveFile _ _ _ = throw $ InvalidOperation "wrong input type"