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

@@ -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
+       then RegFile fn <$> ff cfp
-       else Dir fn <$> fd fp
+       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
+  do
-       return $ fmap (p :/) (removeNonexistent tree)
+    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

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' mcdir
-  nv <- goUp fS
   refreshTreeView' mygui myview nv

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
 }
 

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

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
+  mcdir <- getCwdFromFirstRow myview
-  let cfp = fullPath fsState
+  let fp  = fromMaybe mcdir mfp
-      fp  = fromMaybe cfp 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
+  -- update urlBar
-  let urlpath = fullPath fsState
+  entrySetText (urlBar mygui) mcdir
-  entrySetText (urlBar mygui) urlpath
 
   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'

src/IO/File.hs

@@ -142,27 +142,31 @@ copyDir :: DirCopyMode
         -> FilePath  -- ^ source dir
         -> FilePath  -- ^ destination dir
         -> IO ()
-copyDir cm from to = do
+copyDir cm from' to' = do
-  let fn = takeFileName from
+  from <- canonicalizePath from'
-      destdir = to </> fn
+  to   <- canonicalizePath to'
-
+  go from to
-  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
   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