From f301e2e519440c6f33afc0bfb686c1434a403cc6 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 30 Mar 2016 02:50:32 +0200 Subject: [PATCH] LIB/GTK: use our hpath lib for path type --- .gitmodules | 3 + 3rdparty/hpath | 1 + hsfm.cabal | 2 + src/Data/DirTree.hs | 276 +++++++++++++++++++-------------------- src/GUI/Gtk/Callbacks.hs | 29 ++-- src/GUI/Gtk/MyView.hs | 47 ++++--- src/IO/File.hs | 100 ++++++++------ 7 files changed, 247 insertions(+), 211 deletions(-) create mode 100644 .gitmodules create mode 160000 3rdparty/hpath diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..4afda74 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "3rdparty/hpath"] + path = 3rdparty/hpath + url = https://github.com/hasufell/hpath.git diff --git a/3rdparty/hpath b/3rdparty/hpath new file mode 160000 index 0000000..3c3a2d2 --- /dev/null +++ b/3rdparty/hpath @@ -0,0 +1 @@ +Subproject commit 3c3a2d276646f6530970f675ef32c6089c1e56d4 diff --git a/hsfm.cabal b/hsfm.cabal index 668b95f..90dfe1b 100644 --- a/hsfm.cabal +++ b/hsfm.cabal @@ -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, diff --git a/src/Data/DirTree.hs b/src/Data/DirTree.hs index f44c654..422864f 100644 --- a/src/Data/DirTree.hs +++ b/src/Data/DirTree.hs @@ -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 diff --git a/src/GUI/Gtk/Callbacks.hs b/src/GUI/Gtk/Callbacks.hs index 3b30b30..c9a30f8 100644 --- a/src/GUI/Gtk/Callbacks.hs +++ b/src/GUI/Gtk/Callbacks.hs @@ -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 diff --git a/src/GUI/Gtk/MyView.hs b/src/GUI/Gtk/MyView.hs index 642864d..5966647 100644 --- a/src/GUI/Gtk/MyView.hs +++ b/src/GUI/Gtk/MyView.hs @@ -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 diff --git a/src/IO/File.hs b/src/IO/File.hs index d15df7f..56295f3 100644 --- a/src/IO/File.hs +++ b/src/IO/File.hs @@ -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"