From 0867c8b2e3dc5c6fb50dd7ece739aeab6ba1d625 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 21 Dec 2015 05:41:12 +0100 Subject: [PATCH] LIB/GTK: add '.' and '..' files, remove fsState and improve safety We use canonicalizePaths where we need well-formed paths and cannot rely on the input being sane. --- src/Data/DirTree.hs | 79 +++++++++++++++++++++++++++------------- src/GUI/Gtk/Callbacks.hs | 22 +++-------- src/GUI/Gtk/Data.hs | 1 - src/GUI/Gtk/Gui.hs | 5 +-- src/GUI/Gtk/Utils.hs | 37 +++++++++++-------- src/IO/File.hs | 74 ++++++++++++++++++++++--------------- 6 files changed, 127 insertions(+), 91 deletions(-) diff --git a/src/Data/DirTree.hs b/src/Data/DirTree.hs index 16032d1..927c7e4 100644 --- a/src/Data/DirTree.hs +++ b/src/Data/DirTree.hs @@ -35,6 +35,7 @@ import Data.Default import Data.List ( delete + , isPrefixOf , sort , sortBy , (\\) @@ -66,7 +67,8 @@ import Safe ) import System.Directory ( - doesFileExist + canonicalizePath + , doesFileExist , executable , getPermissions , readable @@ -246,25 +248,26 @@ readFileWith :: (FilePath -> IO a) -> FilePath -> IO (AnchoredFile a b) readFileWith fd ff fp = do + cfp <- canonicalizePath fp + let fn = topDir cfp + bd = baseDir cfp file <- handleDT fn $ do - isFile <- doesFileExist fp + isFile <- doesFileExist cfp if isFile - then RegFile fn <$> ff fp - else Dir fn <$> fd fp + then RegFile fn <$> ff cfp + else Dir fn <$> fd cfp return (bd :/ file) - where - fn = topDir fp - bd = baseDir fp readFile :: FilePath -> IO (AnchoredFile FileInfo FileInfo) -readFile = readFileWith getFileInfo getFileInfo +readFile fp = readFileWith getFileInfo getFileInfo =<< canonicalizePath fp -- |Build a list of AnchoredFile, given the path to a directory, filling -- the free variables via `getFileInfo`. readDirectory :: FilePath -> IO [AnchoredFile FileInfo FileInfo] -readDirectory = readDirectoryWith getFileInfo getFileInfo +readDirectory fp = readDirectoryWith getFileInfo getFileInfo + =<< canonicalizePath fp -- | same as readDirectory but allows us to, for example, use @@ -273,7 +276,8 @@ readDirectoryWith :: (FilePath -> IO a) -> (FilePath -> IO b) -> FilePath -> IO [AnchoredFile a b] -readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff p +readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff + =<< canonicalizePath p @@ -284,15 +288,6 @@ readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff p --- | builds a File from the contents of the directory passed to it, saving --- the base directory in the Anchored* wrapper. Errors are caught in the tree in --- the Failed constructor. The 'file' fields initially are populated with full --- paths to the files they are abstracting. -build :: FilePath -> IO [AnchoredFile FilePath FilePath] -build = buildWith' buildAtOnce' return return -- we say 'return' here to get - -- back a tree of FilePaths - - -- -- -- helpers: -- -- -- @@ -308,17 +303,20 @@ buildWith' :: Builder a b -> FilePath -> IO [AnchoredFile a b] buildWith' bf' fd ff p = - do tree <- bf' fd ff p - return $ fmap (p :/) (removeNonexistent tree) + do + cfp <- canonicalizePath p + tree <- bf' fd ff cfp + return $ fmap (cfp :/) (removeNonexistent tree) -- IO function passed to our builder and finally executed here: buildAtOnce' :: Builder a b buildAtOnce' fd ff p = do - contents <- getDirsFiles p + cfp <- canonicalizePath p + contents <- getAllDirsFiles cfp for contents $ \n -> handleDT n $ do - let subf = p n + let subf = cfp n do isFile <- doesFileExist subf if isFile then RegFile n <$> ff subf @@ -419,6 +417,13 @@ topDir = last . splitDirectories baseDir = joinPath . init . splitDirectories +hiddenFile :: FilePath -> Bool +hiddenFile "." = False +hiddenFile ".." = False +hiddenFile str + | "." `isPrefixOf` str = True + | otherwise = False + ---- IO HELPERS: ---- @@ -429,6 +434,12 @@ goUp af@("" :/ _) = return af goUp (bp :/ _) = Data.DirTree.readFile bp +goUp' :: FilePath -> IO (AnchoredFile FileInfo FileInfo) +goUp' fp = do + cfp <- canonicalizePath fp + Data.DirTree.readFile $ baseDir cfp + + getContents :: AnchoredFile FileInfo FileInfo -> IO [AnchoredFile FileInfo FileInfo] getContents (bp :/ Dir n _) = readDirectory (bp n) @@ -436,6 +447,23 @@ getContents _ = return [] -- |Get all files of a given directory and return them as a List. +-- This includes "." and "..". +getAllDirsFiles :: FilePath -> IO [FilePath] +getAllDirsFiles fp = do + dirstream <- PFD.openDirStream fp + let mdirs :: [FilePath] -> IO [FilePath] + mdirs dirs = do + dir <- PFD.readDirStream dirstream + if dir == "" + then return dirs + else mdirs (dir : dirs) + dirs <- mdirs [] + PFD.closeDirStream dirstream + return dirs + + +-- |Get all files of a given directory and return them as a List. +-- This excludes "." and "..". getDirsFiles :: FilePath -> IO [FilePath] getDirsFiles fp = do dirstream <- PFD.openDirStream fp @@ -444,18 +472,17 @@ getDirsFiles fp = do dir <- PFD.readDirStream dirstream if dir == "" then return dirs - else mdirs (instert dir dirs) + else mdirs (insert dir dirs) dirs <- mdirs [] PFD.closeDirStream dirstream return dirs where - instert dir dirs = case dir of + insert dir dirs = case dir of "." -> dirs ".." -> dirs _ -> dir : dirs - -- |Gets all file information. getFileInfo :: FilePath -> IO FileInfo getFileInfo fp = do diff --git a/src/GUI/Gtk/Callbacks.hs b/src/GUI/Gtk/Callbacks.hs index 821b9cd..b214e9e 100644 --- a/src/GUI/Gtk/Callbacks.hs +++ b/src/GUI/Gtk/Callbacks.hs @@ -54,7 +54,6 @@ import System.Glib.UTFString -- Interaction with mutable references: -- -- * 'settings mygui' modifies --- * 'fsState' reads setCallbacks :: MyGUI -> MyView -> IO () setCallbacks mygui myview = do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do @@ -64,9 +63,10 @@ setCallbacks mygui myview = do _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do [Control] <- eventModifier "h" <- fmap glibToString eventKeyName + mcdir <- liftIO $ getCwdFromFirstRow myview liftIO $ modifyTVarIO (settings mygui) (\x -> x { showHidden = not . showHidden $ x}) - >> (refreshTreeView' mygui myview =<< readTVarIO (fsState myview)) + >> refreshTreeView mygui myview (Just mcdir) _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do [Alt] <- eventModifier "Up" <- fmap glibToString eventKeyName @@ -100,10 +100,6 @@ urlGoTo mygui myview = do -- |Supposed to be used with 'withRow'. Opens a file or directory. --- --- Interaction with mutable references: --- --- * 'fsState' reads open :: Row -> MyGUI -> MyView -> IO () open row mygui myview = case row of @@ -116,10 +112,6 @@ open row mygui myview = -- |Supposed to be used with 'withRow'. Deletes a file or directory. --- --- Interaction with mutable references: --- --- * 'fsState' reads del :: Row -> MyGUI -> MyView -> IO () del row mygui myview = case row of @@ -149,7 +141,6 @@ del row mygui myview = -- Interaction with mutable references: -- -- * 'operationBuffer' writes --- * 'fsState' reads copyInit :: Row -> MyGUI -> MyView -> IO () copyInit row mygui myview = writeTVarIO (operationBuffer myview) (FCopy . CP1 $ fullPath row) @@ -160,13 +151,13 @@ copyInit row mygui myview = -- Interaction with mutable references: -- -- * 'operationBuffer' reads --- * 'fsState' reads copyFinal :: MyGUI -> MyView -> IO () copyFinal mygui myview = do op <- readTVarIO (operationBuffer myview) + mcdir <- getCwdFromFirstRow myview case op of FCopy (CP1 source) -> do - dest <- fullPath <$> readTVarIO (fsState myview) + let dest = mcdir isFile <- doesFileExist source let cmsg = "Really copy file \"" ++ source ++ "\"" ++ " to \"" ++ dest ++ "\"?" @@ -183,11 +174,10 @@ copyFinal mygui myview = do -- -- * 'rawModel' reads -- * 'sortedModel' reads --- * 'fsState' reads upDir :: MyGUI -> MyView -> IO () upDir mygui myview = do + mcdir <- getCwdFromFirstRow myview rawModel' <- readTVarIO $ rawModel myview sortedModel' <- readTVarIO $ sortedModel myview - fS <- readTVarIO $ fsState myview - nv <- goUp fS + nv <- goUp' mcdir refreshTreeView' mygui myview nv diff --git a/src/GUI/Gtk/Data.hs b/src/GUI/Gtk/Data.hs index 16b8782..7e2b7f2 100644 --- a/src/GUI/Gtk/Data.hs +++ b/src/GUI/Gtk/Data.hs @@ -65,7 +65,6 @@ data MyView = MkMyView { rawModel :: TVar (ListStore Row) , sortedModel :: TVar (TypedTreeModelSort Row) , filteredModel :: TVar (TypedTreeModelFilter Row) - , fsState :: TVar (AnchoredFile FileInfo FileInfo) , operationBuffer :: TVar FileOperation } diff --git a/src/GUI/Gtk/Gui.hs b/src/GUI/Gtk/Gui.hs index d3de584..f4a791d 100644 --- a/src/GUI/Gtk/Gui.hs +++ b/src/GUI/Gtk/Gui.hs @@ -113,7 +113,6 @@ import System.Process -- Interaction with mutable references: -- -- * 'settings' creates --- * 'fsState' creates -- * 'operationBuffer' creates -- * 'rawModel' creates -- * 'filteredModel' creates @@ -129,8 +128,6 @@ startMainWindow startdir = do filePix <- getIcon IFile 24 errorPix <- getIcon IError 24 - fsState <- Data.DirTree.readFile startdir >>= newTVarIO - operationBuffer <- newTVarIO None builder <- builderNew @@ -163,7 +160,7 @@ startMainWindow startdir = do -- create initial list store model with unsorted data rawModel <- newTVarIO =<< listStoreNew =<< Data.DirTree.getContents - =<< readTVarIO fsState + =<< Data.DirTree.readFile startdir filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x []) =<< readTVarIO rawModel diff --git a/src/GUI/Gtk/Utils.hs b/src/GUI/Gtk/Utils.hs index 010801f..bf4eef9 100644 --- a/src/GUI/Gtk/Utils.hs +++ b/src/GUI/Gtk/Utils.hs @@ -25,6 +25,7 @@ import Data.List import Data.Maybe ( fromMaybe + , fromJust ) import Data.Traversable ( @@ -84,19 +85,29 @@ withRow mygui myview io = do -- |Create the 'ListStore' of files/directories from the current directory. -- This is the function which maps the Data.DirTree data structures -- into the GTK+ data structures. --- --- Interaction with mutable references: --- --- * 'fsState' writes fileListStore :: AnchoredFile FileInfo FileInfo -- ^ current dir -> MyView -> IO (ListStore Row) fileListStore dt myview = do - writeTVarIO (fsState myview) dt cs <- Data.DirTree.getContents dt listStoreNew cs +-- |Currently unsafe. This is used to obtain any row (possibly the '.' row) +-- and extract the "current working directory" from it. +-- +-- Interaction with mutable references: +-- +-- * 'rawModel' reads +getCwdFromFirstRow :: MyView + -> IO FilePath +getCwdFromFirstRow myview = do + rawModel' <- readTVarIO $ rawModel myview + iter <- fromJust <$> treeModelGetIterFirst rawModel' + af <- treeModelGetRow rawModel' iter + return $ anchor af + + -- |Re-reads the current directory or the given one and updates the TreeView. -- -- The operation may fail with: @@ -106,16 +117,14 @@ fileListStore dt myview = do -- -- Interaction with mutable references: -- --- * 'fsState' reads -- * 'rawModel' writes refreshTreeView :: MyGUI -> MyView -> Maybe FilePath -> IO () refreshTreeView mygui myview mfp = do - fsState <- readTVarIO $ fsState myview - let cfp = fullPath fsState - fp = fromMaybe cfp mfp + mcdir <- getCwdFromFirstRow myview + let fp = fromMaybe mcdir mfp -- TODO catch exceptions dirSanityThrow fp @@ -148,7 +157,6 @@ refreshTreeView' mygui myview dt = do -- -- Interaction with mutable references: -- --- * 'fsState' reads -- * 'rawModel' reads -- * 'filteredModel' writes -- * 'sortedModel' writes @@ -162,11 +170,10 @@ constructTreeView mygui myview = do cMD' = cMD mygui render' = renderTxt mygui - fsState <- readTVarIO $ fsState myview + mcdir <- getCwdFromFirstRow myview - -- update urlBar, this will break laziness slightly, probably - let urlpath = fullPath fsState - entrySetText (urlBar mygui) urlpath + -- update urlBar + entrySetText (urlBar mygui) mcdir rawModel' <- readTVarIO $ rawModel myview @@ -178,7 +185,7 @@ constructTreeView mygui myview = do row <- (name . file) <$> treeModelGetRow rawModel' iter if hidden then return True - else return $ not ("." `isPrefixOf` row) + else return $ not . hiddenFile $ row -- sorting sortedModel' <- treeModelSortNewWithModel filteredModel' diff --git a/src/IO/File.hs b/src/IO/File.hs index 73638d0..f9c40b0 100644 --- a/src/IO/File.hs +++ b/src/IO/File.hs @@ -142,27 +142,31 @@ copyDir :: DirCopyMode -> FilePath -- ^ source dir -> FilePath -- ^ destination dir -> IO () -copyDir cm from to = do - let fn = takeFileName from - destdir = to fn - - dirSanityThrow from - dirSanityThrow to - throwDestinationInSource from to - throwSameFile from destdir - - createDestdir destdir - - contents <- getDirsFiles from - - for_ contents $ \f -> do - let ffn = from f - fs <- PF.getSymbolicLinkStatus ffn - case (PF.isSymbolicLink fs, PF.isDirectory fs) of - (True, _) -> recreateSymlink destdir f ffn - (_, True) -> copyDir cm ffn destdir - (_, _) -> copyFileToDir ffn destdir +copyDir cm from' to' = do + from <- canonicalizePath from' + to <- canonicalizePath to' + go from to where + go from to = do + let fn = takeFileName from + destdir = to fn + + dirSanityThrow from + dirSanityThrow to + throwDestinationInSource from to + throwSameFile from destdir + + createDestdir destdir + + contents <- getDirsFiles from + + for_ contents $ \f -> do + let ffn = from f + fs <- PF.getSymbolicLinkStatus ffn + case (PF.isSymbolicLink fs, PF.isDirectory fs) of + (True, _) -> recreateSymlink destdir f ffn + (_, True) -> copyDir cm ffn destdir + (_, _) -> copyFileToDir ffn destdir createDestdir destdir = case cm of Merge -> @@ -199,7 +203,9 @@ copyDir cm from to = do copyFile :: FilePath -- ^ source file -> FilePath -- ^ destination file -> IO () -copyFile from to = do +copyFile from' to' = do + from <- canonicalizePath from' + to <- canonicalizePath to' fileSanityThrow from throwNotAbsolute to throwDirDoesExist to @@ -218,7 +224,9 @@ copyFile from to = do -- * `PathNotAbsolute` if the target directory is not absolute -- * anything that `copyFile` throws copyFileToDir :: FilePath -> FilePath -> IO () -copyFileToDir from to = do +copyFileToDir from' to' = do + from <- canonicalizePath from' + to <- canonicalizePath to' let name = takeFileName from dirSanityThrow to copyFile from (to name) @@ -244,7 +252,8 @@ easyCopy cm from to = doFileOrDir from (copyDir cm from to) -- * `PathNotAbsolute` if the file is not absolute -- * anything that `removeFile` throws deleteFile :: FilePath -> IO () -deleteFile fp = do +deleteFile fp' = do + fp <- canonicalizePath fp' fileSanityThrow fp removeFile fp @@ -258,7 +267,8 @@ deleteFile fp = do -- * `PathNotAbsolute` if the dir is not absolute -- * anything that `removeDirectory` throws deleteDir :: FilePath -> IO () -deleteDir fp = do +deleteDir fp' = do + fp <- canonicalizePath fp' dirSanityThrow fp removeDirectory fp @@ -271,7 +281,8 @@ deleteDir fp = do -- * `PathNotAbsolute` if the dir is not absolute -- * anything that `removeDirectoryRecursive` throws deleteDirRecursive :: FilePath -> IO () -deleteDirRecursive fp = do +deleteDirRecursive fp' = do + fp <- canonicalizePath fp' dirSanityThrow fp removeDirectoryRecursive fp @@ -284,7 +295,9 @@ deleteDirRecursive fp = do -- * `PathNotAbsolute` if the file/dir is not absolute -- * anything that `deleteDir`/`deleteFile` throws easyDelete :: FilePath -> IO () -easyDelete fp = doFileOrDir fp (deleteDir fp) (deleteFile fp) +easyDelete fp' = do + fp <- canonicalizePath fp' + doFileOrDir fp (deleteDir fp) (deleteFile fp) @@ -301,7 +314,8 @@ easyDelete fp = doFileOrDir fp (deleteDir fp) (deleteFile fp) -- * `PathNotAbsolute` if the file is not absolute openFile :: FilePath -> IO ProcessHandle -openFile fp = do +openFile fp' = do + fp <- canonicalizePath fp' fileSanityThrow fp spawnProcess "xdg-open" [fp] @@ -316,7 +330,8 @@ openFile fp = do executeFile :: FilePath -- ^ program -> [String] -- ^ arguments -> IO ProcessHandle -executeFile prog args = do +executeFile prog' args = do + prog <- canonicalizePath prog' fileSanityThrow prog unlessM (fileAccess prog False False True) (throw $ FileNotExecutable prog) spawnProcess prog args @@ -336,7 +351,8 @@ executeFile prog args = do -- -- * `throwFileDoesNotExist` if the filepath is neither a file or directory doFileOrDir :: FilePath -> IO () -> IO () -> IO () -doFileOrDir fp iod iof = do +doFileOrDir fp' iod iof = do + fp <- canonicalizePath fp' isD <- doesDirectoryExist fp isF <- doesFileExist fp case (isD, isF) of