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

LIB/GTK: refactor File base type

Browse Source 
We have now ditched AnchoredFile and just use File with Path Abs
in the path field.

This is useful since we now:
* don't allow "." or ".." as filenames anymore
* normalise paths in our path parsers and reject paths with ".."

This also allows us to know that filepaths are always valid. In addition
the 'basename' function from hpath may throw an exception if run
on the root dir "/". This exception is basically uncatched currently,
which is fine, because it's not a selectable directory.
This commit is contained in:
Julian Ospald
2016-04-15 14:23:41 +02:00
parent 3d15a66350
commit bb6c1b3cda
8 changed files with 223 additions and 392 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
src/HSFM/GUI/Gtk/Callbacks.hs
View File

@@ -58,6 +58,7 @@ import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
import Prelude hiding(readFile)
import System.Glib.UTFString
(
glibToString
@@ -237,8 +238,8 @@ urlGoTo mygui myview = withErrorDialog $ do
open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
ADirOrSym r -> do
nv <- HSFM.FileSystem.FileType.readFileWithFileInfo $ fullPath r
DirOrSym r -> do
nv <- readFile getFileInfo $ fullPath r
refreshView' mygui myview nv
r ->
void $ openFile r
@@ -356,7 +357,8 @@ renameF [item] _ _ = withErrorDialog $ do
for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ P.fpToString (fullPathS item)
++ "\"" ++ " to \""
++ P.fpToString (P.fromAbs (anchor item P.</> fn)) ++ "\"?"
++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $
HSFM.FileSystem.FileOperations.renameFile item fn
renameF _ _ _ = withErrorDialog

3
src/HSFM/GUI/Gtk/Data.hs
View File

@@ -91,13 +91,14 @@ data FMSettings = MkFMSettings {
data FMView = FMTreeView TreeView
| FMIconView IconView
type Item = AnchoredFile FileInfo
type Item = File FileInfo
-- |This describes the contents of the current vie and is separated from MyGUI,
-- because we might want to have multiple views.
data MyView = MkMyView {
view :: TVar FMView
, cwd :: MVar Item
, rawModel :: TVar (ListStore Item)
, sortedModel :: TVar (TypedTreeModelSort Item)
, filteredModel :: TVar (TypedTreeModelFilter Item)

36
src/HSFM/GUI/Gtk/MyView.hs
View File

@@ -46,6 +46,7 @@ import Data.Foldable
import Data.Maybe
(
catMaybes
, fromJust
)
import Graphics.UI.Gtk
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks)
@@ -62,6 +63,7 @@ import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Icons
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
import Prelude hiding(readFile)
import System.INotify
(
addWatch
@@ -79,7 +81,9 @@ import System.IO.Error
-- |Constructs the initial MyView object with a few dummy models.
-- It also initializes the callbacks.
createMyView :: MyGUI -> IO FMView -> IO MyView
createMyView :: MyGUI
-> IO FMView
-> IO MyView
createMyView mygui iofmv = do
operationBuffer <- newTVarIO None
@@ -91,7 +95,7 @@ createMyView mygui iofmv = do
=<< readTVarIO rawModel
sortedModel <- newTVarIO =<< treeModelSortNewWithModel
=<< readTVarIO filteredModel
cwd <- newEmptyMVar
view' <- iofmv
view <- newTVarIO view'
@@ -194,6 +198,7 @@ createTreeView = do
-- |Re-reads the current directory or the given one and updates the View.
-- This is more or less a wrapper around `refreshView'`
--
-- If the third argument is Nothing, it tries to re-read the current directory.
-- If that fails, it reads "/" instead.
@@ -208,12 +213,12 @@ refreshView mygui myview mfp =
case mfp of
Just fp -> do
-- readFileWithFileInfo can just outright fail...
ecdir <- tryIOError (HSFM.FileSystem.FileType.readFileWithFileInfo fp)
ecdir <- tryIOError (readFile getFileInfo fp)
case ecdir of
Right cdir ->
-- ...or return an `AnchordFile` with a Failed constructor,
-- both of which need to be handled here
if (failed . file $ cdir)
if (failed cdir)
then refreshView mygui myview =<< getAlternativeDir
else refreshView' mygui myview cdir
Left _ -> refreshView mygui myview =<< getAlternativeDir
@@ -221,7 +226,7 @@ refreshView mygui myview mfp =
where
getAlternativeDir = do
ecd <- try (getCurrentDir myview) :: IO (Either SomeException
(AnchoredFile FileInfo))
Item)
case ecd of
Right dir -> return (Just $ fullPath dir)
Left _ -> return (P.parseAbs "/")
@@ -233,14 +238,17 @@ refreshView mygui myview mfp =
-- calls `refreshView` with the 3rd argument being Nothing.
refreshView' :: MyGUI
-> MyView
-> AnchoredFile FileInfo
-> Item
-> IO ()
refreshView' mygui myview dt@(ADirOrSym _) = do
refreshView' mygui myview dt@(DirOrSym _) = do
newRawModel <- fileListStore dt myview
writeTVarIO (rawModel myview) newRawModel
view' <- readTVarIO $ view myview
_ <- tryTakeMVar (cwd myview)
putMVar (cwd myview) dt
-- get selected items
tps <- getSelectedTreePaths mygui myview
trs <- catMaybes <$> mapM (treeRowReferenceNew newRawModel) tps
@@ -255,7 +263,7 @@ refreshView' mygui myview dt@(ADirOrSym _) = do
ntps <- mapM treeRowReferenceGetPath trs
mapM_ (treeSelectionSelectPath tvs) ntps
_ -> return ()
refreshView' mygui myview (_ :/ Failed{}) = refreshView mygui myview Nothing
refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
refreshView' _ _ _ = return ()
@@ -288,7 +296,7 @@ constructView mygui myview = do
view' <- readTVarIO $ view myview
cdirp <- anchor <$> getFirstItem myview
cdirp <- path <$> getCurrentDir myview
-- update urlBar
entrySetText (urlBar mygui) (P.fromAbs cdirp)
@@ -300,7 +308,7 @@ constructView mygui myview = do
writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui)
item <- (name . file) <$> treeModelGetRow rawModel' iter
item <- treeModelGetRow rawModel' iter >>= (P.basename . path)
if hidden
then return True
else return $ not . P.hiddenFile $ item
@@ -318,13 +326,13 @@ constructView mygui myview = do
-- set values
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . file)
dirtreePix
treeModelSetColumn rawModel' (makeColumnIdString 1)
(P.fromRel . name . file)
(P.toFilePath . fromJust . P.basename . path)
treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . file)
packModTime
treeModelSetColumn rawModel' (makeColumnIdString 3)
(packPermissions . file)
packPermissions
-- update model of view
case view' of

22
src/HSFM/GUI/Gtk/Utils.hs
View File

@@ -21,6 +21,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
module HSFM.GUI.Gtk.Utils where
import Control.Concurrent.MVar
(
readMVar
)
import Control.Concurrent.STM
(
readTVarIO
@@ -37,6 +41,7 @@ import Data.Traversable
import Graphics.UI.Gtk
import HSFM.FileSystem.FileType
import HSFM.GUI.Gtk.Data
import Prelude hiding(getContents)
@@ -100,29 +105,28 @@ withItems 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.
fileListStore :: AnchoredFile FileInfo -- ^ current dir
fileListStore :: Item -- ^ current dir
-> MyView
-> IO (ListStore Item)
fileListStore dt _ = do
cs <- HSFM.FileSystem.FileType.getContents dt
cs <- getContents getFileInfo dt
listStoreNew cs
-- |Currently unsafe. This is used to obtain any item (possibly the '.' item)
-- and extract the "current working directory" from it.
-- |Currently unsafe. This is used to obtain any item, which will
-- fail if there is none.
getFirstItem :: MyView
-> IO (AnchoredFile FileInfo)
-> IO Item
getFirstItem myview = do
rawModel' <- readTVarIO $ rawModel myview
iter <- fromJust <$> treeModelGetIterFirst rawModel'
treeModelGetRow rawModel' iter
-- |Currently unsafe. Gets the current directory via `getFirstItem` and
-- `goUp`.
-- |Reads the current directory from MyView.
getCurrentDir :: MyView
-> IO (AnchoredFile FileInfo)
getCurrentDir myview = getFirstItem myview >>= goUp
-> IO Item
getCurrentDir myview = readMVar (cwd myview)