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.
This commit is contained in:
parent
fe6145d5be
commit
0867c8b2e3
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue