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

LIB/GTK: add '.' and '..' files, remove fsState and improve safety

Browse Source 
We use canonicalizePaths where we need well-formed paths and cannot
rely on the input being sane.
This commit is contained in:
Julian Ospald 2015-12-21 05:41:12 +01:00
parent fe6145d5be
commit 0867c8b2e3
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
6 changed files with 127 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
src/Data/DirTree.hs
View File

@ -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

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

@ -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

1
src/GUI/Gtk/Data.hs
View File

@ -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
}

5
src/GUI/Gtk/Gui.hs
View File

@ -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

37
src/GUI/Gtk/Utils.hs
View File

@ -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'

74
src/IO/File.hs
View File

@ -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