Blub

.gitignore

@@ -6,4 +6,3 @@ cabal.sandbox.config
 *.prof
 *.old
 .liquid/
-3rdparty/hpath

.gitmodules

@@ -0,0 +1,9 @@
+[submodule "3rdparty/hpath"]
+	path = 3rdparty/hpath
+	url = https://github.com/hasufell/hpath.git
+[submodule "3rdparty/hinotify"]
+	path = 3rdparty/hinotify
+	url = https://github.com/hasufell/hinotify.git
+[submodule "3rdparty/simple-sendfile"]
+	path = 3rdparty/simple-sendfile
+	url = https://github.com/hasufell/simple-sendfile.git

.travis.yml

@@ -1,55 +0,0 @@
-# See https://github.com/hvr/multi-ghc-travis for more information
-
-language: c
-
-sudo: required
-dist: trusty
-
-matrix:
-  include:
-    - env: CABALVER=1.24 GHCVER=7.10.2
-      addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.2,libgtk2.0-dev,libgtk-3-dev], sources: [hvr-ghc]}}
-    - env: CABALVER=1.24 GHCVER=8.0.1
-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,libgtk2.0-dev,libgtk-3-dev], sources: [hvr-ghc]}}
-    - env: CABALVER=head GHCVER=head
-      addons: {apt: {packages: [cabal-install-head,ghc-head,libgtk2.0-dev,libgtk-3-dev],  sources: [hvr-ghc]}}
-
-  allow_failures:
-    - env: CABALVER=head GHCVER=head
-
-before_install:
- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
-
-install:
- - cabal --version
- - travis_retry cabal update
- - cabal sandbox init
- - cabal install alex happy
- - export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
- - cabal install gtk2hs-buildtools
- - cabal install --only-dependencies --enable-tests -j
-
-script:
- - cabal configure --enable-tests -v2
- - cabal build
- - cabal test
- - cabal check
- - cabal sdist
-# check that the generated source-distribution can be built & installed
- - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
-   cd dist/;
-   cabal sandbox init;
-   if [ -f "$SRC_TGZ" ]; then
-      cabal install alex happy;
-      export PATH="$(pwd)/.cabal-sandbox/bin:$PATH";
-      cabal install gtk2hs-buildtools;
-      cabal install "$SRC_TGZ" --enable-tests;
-   else
-      echo "expected '$SRC_TGZ' not found";
-      exit 1;
-   fi
-
-notifications:
-  email:
-    - hasufell@posteo.de
-

README.md

@@ -1,7 +1,7 @@
 HSFM
 ====
 
-[![Build Status](https://api.travis-ci.org/hasufell/hsfm.png?branch=master)](http://travis-ci.org/hasufell/hsfm)
+__NOTE: This project is in a highly experimental state! Don't complain if it deletes your whole home directory. You should use a chroot, docker environment or similar for testing.__
 
 A Gtk+:3 filemanager written in Haskell.
 
@@ -21,7 +21,12 @@ Installation
 ------------
 
 ```
+git submodule update --init --recursive
 cabal sandbox init
+cabal sandbox add-source 3rdparty/hinotify
+cabal sandbox add-source 3rdparty/hpath
+cabal sandbox add-source 3rdparty/hpath/3rdparty/posix-paths
+cabal sandbox add-source 3rdparty/simple-sendfile
 cabal install alex happy
 export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
 cabal install gtk2hs-buildtools

data/Gtk/builder.xml

@@ -364,7 +364,6 @@
           <object class="GtkNotebook" id="notebook">
             <property name="visible">True</property>
             <property name="can_focus">True</property>
-            <property name="scrollable">True</property>
             <child>
               <placeholder/>
             </child>

hacking/HACKING.md

@@ -19,6 +19,20 @@ documentation.
 
 ## Hacking Overview
 
+The main data structure for the IO related File type is in
+[HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which
+should be seen as a library. This is the entry point where
+[directory contents are read](./../src/HSFM/FileSystem/FileType.hs#L465)
+and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302).
+The File type uses a safe Path type under the hood instead of Strings,
+utilizing the [hpath](https://github.com/hasufell/hpath) library.
+Note that mostly only absolute paths are allowed on type level to improve
+path and thread safety.
+
+File operations (like copy, delete etc) are defined at
+[HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs)
+which use this File type.
+
 Only a GTK GUI is currently implemented, the entry point being
 [HSFM.GUI.Gtk](./../src/HSFM/GUI/Gtk.hs). From there it flows down
 to creating a [MyGUI object](./../src/HSFM/GUI/Gtk/Data.hs#L51) in
@@ -61,8 +75,6 @@ This leads to the following benefits:
 * we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist")
 * filepath functions like `(</>)` are now predictable and safe in contrast to the version from the `filepath` package
 
-The [hpath](https://hackage.haskell.org/package/hpath) library does exactly that for us.
-
 The only problem with this approach is that most libraries are still String
 based. Some provide dedicated `Foo.ByteString` modules though, but it
 might be necessary to fork libraries.
@@ -86,10 +98,17 @@ the call stack at point `b` in time, when the file information in memory
 could already be out of date. There are two approaches to make this less
 sucky:
 * use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes
-* when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized  then the file at the given path is read and the copy/move/whatnot function carried out immediately
+* when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized via `runFileOp`, then the file at the given path is read and the copy/move/whatnot function carried out immediately
+
+This means we should only interact with the `HSFM.FileSystem.FileOperation`
+module via the operation data types `FileOperation`, `Copy` and `Move` and
+the `runFileOp` function. This doesn't completely solve the problem, but for
+the rest we have to trust the posix functions to throw the proper exceptions.
 
 In addition, we don't use the `directory` package, which is dangerous
-and broken. Instead, we use the [HPath.IO](https://hackage.haskell.org/package/hpath/docs/HPath-IO.html).
+and broken. Instead, we implement our own low-level wrappers around
+the posix functions, so we have proper control over the internals
+and know the possible exceptions.
 
 ### Exception handling
 
@@ -97,7 +116,7 @@ Exceptions are good. We don't want to wrap everything in Maybe/Either types
 unless we want to handle failure immediately. Otherwise we need to make
 sure that at least at some point IOExceptions are caught and visualized
 to the user. This is often done via e.g. `withErrorDialog` which catches
-`IOException` and [HPathIOException](https://hackage.haskell.org/package/hpath/docs/HPath-IO-Errors.html#t:HPathIOException).
+`IOException` and `FmIOException`.
 
 It's also important to clean up stuff like filedescriptors via
 functions like `bracket` directly in our low-level code in case

hsfm.cabal

@@ -10,7 +10,7 @@ copyright:           Copyright: (c) 2016 Julian Ospald
 homepage:            https://github.com/hasufell/hsfm
 category:            Desktop
 build-type:          Simple
-cabal-version:       >=1.24
+cabal-version:       >=1.10
 
 data-files:
                      LICENSE
@@ -24,23 +24,36 @@ data-files:
 
 library
   exposed-modules:
+                       HSFM.FileSystem.Errors
+                       HSFM.FileSystem.FileOperations
                        HSFM.FileSystem.FileType
-                       HSFM.FileSystem.UtilTypes
+                       HSFM.Settings.Bookmarks
                        HSFM.Utils.IO
                        HSFM.Utils.MyPrelude
 
   build-depends:
-                       base >= 4.8 && < 5,
+                       attoparsec,
+                       base >= 4.7,
                        bytestring,
+                       containers,
                        data-default,
+                       errors,
                        filepath >= 1.3.0.0,
-                       hinotify-bytestring,
+                       hinotify,
-                       hpath >= 0.7.1,
+                       hpath,
+                       monad-loops,
+                       mtl >= 2.2,
+                       old-locale >= 1,
+                       posix-paths,
+                       process,
                        safe,
+                       simple-sendfile,
                        stm,
                        time >= 1.4.2,
                        unix,
-                       utf8-string
+                       unix-bytestring,
+                       utf8-string,
+                       word8
   hs-source-dirs:      src
   default-language:    Haskell2010
   Default-Extensions:  RecordWildCards
@@ -48,14 +61,16 @@ library
                        FlexibleInstances
                        ViewPatterns
   ghc-options:
+    -O2
+    -threaded
     -Wall
+    "-with-rtsopts=-N"
 
 executable hsfm-gtk
   main-is:             HSFM/GUI/Gtk.hs
   other-modules:
                        HSFM.GUI.Glib.GlibString
                        HSFM.GUI.Gtk.Callbacks
-                       HSFM.GUI.Gtk.Callbacks.Utils
                        HSFM.GUI.Gtk.Data
                        HSFM.GUI.Gtk.Dialogs
                        HSFM.GUI.Gtk.Errors
@@ -66,17 +81,20 @@ executable hsfm-gtk
                        HSFM.Utils.MyPrelude
 
   build-depends:
-                       Cabal >= 1.24.0.0,
+                       Cabal >= 1.22.0.0,
-                       base >= 4.8 && < 5,
+                       base >= 4.7,
                        bytestring,
+                       containers,
                        data-default,
                        filepath >= 1.3.0.0,
                        glib >= 0.13,
                        gtk3 >= 0.14.1,
-                       hinotify-bytestring,
+                       hinotify,
-                       hpath >= 0.7.1,
+                       hpath,
                        hsfm,
+                       mtl >= 2.2,
                        old-locale >= 1,
+                       posix-paths,
                        process,
                        safe,
                        simple-sendfile,
@@ -94,9 +112,7 @@ executable hsfm-gtk
                        FlexibleInstances
                        ViewPatterns
   ghc-options:
+    -O2
+    -threaded
     -Wall
-
+    "-with-rtsopts=-N"
-source-repository head
-  type:     git
-  location: https://github.com/hasufell/hsfm
-

src/HSFM/FileSystem/Errors.hs

@@ -0,0 +1,251 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+-- |Provides error handling.
+module HSFM.FileSystem.Errors where
+
+
+import Control.Exception
+import Control.Monad
+  (
+    when
+  , forM
+  )
+import Data.ByteString
+  (
+    ByteString
+  )
+import Data.Typeable
+import Foreign.C.Error
+  (
+    getErrno
+  , Errno
+  )
+import qualified HPath as P
+import HPath
+    (
+      Abs
+    , Path
+    )
+import HSFM.Utils.IO
+import System.IO.Error
+  (
+    catchIOError
+  )
+
+import qualified System.Posix.Directory.ByteString as PFD
+import System.Posix.FilePath
+import qualified System.Posix.Files.ByteString as PF
+
+
+data FmIOException = FileDoesNotExist ByteString
+                   | DirDoesNotExist ByteString
+                   | PathNotAbsolute ByteString
+                   | FileNotExecutable ByteString
+                   | SameFile ByteString ByteString
+                   | NotAFile ByteString
+                   | NotADir ByteString
+                   | DestinationInSource ByteString ByteString
+                   | FileDoesExist ByteString
+                   | DirDoesExist ByteString
+                   | IsSymlink ByteString
+                   | InvalidOperation String
+                   | InvalidFileName
+                   | Can'tOpenDirectory ByteString
+                   | CopyFailed String
+                   | MoveFailed String
+  deriving (Typeable)
+
+
+instance Show FmIOException where
+  show (FileDoesNotExist fp) = "File does not exist:" ++ P.fpToString fp
+  show (DirDoesNotExist fp) = "Directory does not exist: "
+                              ++ P.fpToString fp
+  show (PathNotAbsolute fp) = "Path not absolute: " ++ P.fpToString fp
+  show (FileNotExecutable fp) = "File not executable: "
+                                ++ P.fpToString fp
+  show (SameFile fp1 fp2) = P.fpToString fp1
+                            ++ " and " ++ P.fpToString fp2
+                            ++ " are the same file!"
+  show (NotAFile fp) = "Not a file: " ++ P.fpToString fp
+  show (NotADir fp) = "Not a directory: " ++ P.fpToString fp
+  show (DestinationInSource fp1 fp2) = P.fpToString fp1
+                                       ++ " is contained in "
+                                       ++ P.fpToString fp2
+  show (FileDoesExist fp) = "File does exist: " ++ P.fpToString fp
+  show (DirDoesExist fp) = "Directory does exist: " ++ P.fpToString fp
+  show (IsSymlink fp) = "Is a symlink: " ++ P.fpToString fp
+  show (InvalidOperation str) = "Invalid operation: " ++ str
+  show InvalidFileName = "Invalid file name!"
+  show (Can'tOpenDirectory fp) = "Can't open directory: "
+                                 ++ P.fpToString fp
+  show (CopyFailed str) = "Copying failed: " ++ str
+  show (MoveFailed str) = "Moving failed: " ++ str
+
+
+
+instance Exception FmIOException
+
+
+
+
+    ----------------------------
+    --[ Path based functions ]--
+    ----------------------------
+
+
+throwFileDoesExist :: Path Abs -> IO ()
+throwFileDoesExist fp =
+  whenM (doesFileExist fp) (throw . FileDoesExist
+                                  . P.fromAbs $ fp)
+
+
+throwDirDoesExist :: Path Abs -> IO ()
+throwDirDoesExist fp =
+  whenM (doesDirectoryExist fp) (throw . DirDoesExist
+                                       . P.fromAbs $ fp)
+
+
+throwFileDoesNotExist :: Path Abs -> IO ()
+throwFileDoesNotExist fp =
+  whenM (doesFileExist fp) (throw . FileDoesExist
+                                  . P.fromAbs $ fp)
+
+
+throwDirDoesNotExist :: Path Abs -> IO ()
+throwDirDoesNotExist fp =
+  whenM (doesDirectoryExist fp) (throw . DirDoesExist
+                                       . P.fromAbs $ fp)
+
+
+throwSameFile :: Path Abs -- ^ will be canonicalized
+              -> Path Abs -- ^ will be canonicalized
+              -> IO ()
+throwSameFile fp1 fp2 = do
+  fp1' <- fmap P.fromAbs $ P.canonicalizePath fp1
+  -- TODO: clean this up... if canonicalizing fp2 fails we try to
+  --       canonicalize `dirname fp2`
+  fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
+                       (\_ -> fmap P.fromAbs
+                       $ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2)
+                                <$> (P.canonicalizePath $ P.dirname fp2))
+  when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
+
+
+-- |Checks whether the destination directory is contained
+-- within the source directory by comparing the device+file ID of the
+-- source directory with all device+file IDs of the parent directories
+-- of the destination.
+throwDestinationInSource :: Path Abs -- ^ source dir
+                         -> Path Abs -- ^ full destination, `dirname dest`
+                                     --   must exist
+                         -> IO ()
+throwDestinationInSource source dest = do
+  source' <- P.canonicalizePath source
+  dest'   <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
+             <$> (P.canonicalizePath $ P.dirname dest)
+  dids <- forM (P.getAllParents dest') $ \p -> do
+          fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
+          return (PF.deviceID fs, PF.fileID fs)
+  sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
+              $ PF.getSymbolicLinkStatus (P.fromAbs source')
+  when (elem sid dids)
+       (throw $ DestinationInSource (P.fromAbs dest)
+                                    (P.fromAbs source))
+
+
+-- |Checks if the given file exists and is not a directory. This follows
+-- symlinks, but will return True if the symlink is broken.
+doesFileExist :: Path Abs -> IO Bool
+doesFileExist fp =
+  handleIOError (\_ -> return False) $ do
+    fp' <- fmap P.fromAbs $ P.canonicalizePath fp
+    fs  <- PF.getFileStatus fp'
+    return $ not . PF.isDirectory $ fs
+
+
+-- |Checks if the given file exists and is a directory. This follows
+-- symlinks, but will return False if the symlink is broken.
+doesDirectoryExist :: Path Abs -> IO Bool
+doesDirectoryExist fp =
+  handleIOError (\_ -> return False) $ do
+    fp' <- fmap P.fromAbs $ P.canonicalizePath fp
+    fs  <- PF.getFileStatus fp'
+    return $ PF.isDirectory fs
+
+
+-- |Checks whether the directory at the given path exists and can be
+-- opened. This invokes `openDirStream`.
+canOpenDirectory :: Path Abs -> IO Bool
+canOpenDirectory fp =
+  handleIOError (\_ -> return False) $ do
+    bracket (PFD.openDirStream . P.fromAbs $ fp)
+            PFD.closeDirStream
+            (\_ -> return ())
+    return True
+
+
+-- |Throws a `Can'tOpenDirectory` FmIOException if the directory at the given
+-- path cannot be opened.
+throwCantOpenDirectory :: Path Abs -> IO ()
+throwCantOpenDirectory fp =
+  unlessM (canOpenDirectory fp)
+          (throw . Can'tOpenDirectory . P.fromAbs $ fp)
+
+
+
+    --------------------------------
+    --[ Error handling functions ]--
+    --------------------------------
+
+
+-- |Carries out an action, then checks if there is an IOException and
+-- a specific errno. If so, then it carries out another action, otherwise
+-- it rethrows the error.
+catchErrno :: [Errno] -- ^ errno to catch
+           -> IO a    -- ^ action to try, which can raise an IOException
+           -> IO a    -- ^ action to carry out in case of an IOException and
+                      --   if errno matches
+           -> IO a
+catchErrno en a1 a2 =
+  catchIOError a1 $ \e -> do
+    errno <- getErrno
+    if errno `elem` en
+      then a2
+      else ioError e
+
+
+-- |Execute the given action and retrow IO exceptions as a new Exception
+-- that have the given errno. If errno does not match the exception is rethrown
+-- as is.
+rethrowErrnoAs :: Exception e
+               => [Errno]       -- ^ errno to catch
+               -> e             -- ^ rethrow as if errno matches
+               -> IO a          -- ^ action to try
+               -> IO a
+rethrowErrnoAs en fmex action = catchErrno en action (throw fmex)
+
+
+
+-- |Like `catchIOError`, with arguments swapped.
+handleIOError :: (IOError -> IO a) -> IO a -> IO a
+handleIOError = flip catchIOError
+

src/HSFM/FileSystem/FileOperations.hs

@@ -0,0 +1,650 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+-- |This module provides all the atomic IO related file operations like
+-- copy, delete, move and so on. It operates primarily on `AnchoredFile`, which
+-- is guaranteed to be well-formed.
+--
+-- It would be nicer to pass states around, but the filesystem state changes
+-- too quickly and cannot be relied upon. Lazy implementations of filesystem
+-- trees have been tried as well, but they can introduce subtle bugs.
+module HSFM.FileSystem.FileOperations where
+
+
+import Control.Exception
+  (
+    bracket
+  , throw
+  )
+import Control.Monad
+  (
+    forM_
+  , unless
+  , void
+  , when
+  )
+import Control.Monad.Loops
+  (
+    dropWhileM
+  )
+import Data.ByteString
+  (
+    ByteString
+  )
+import Data.Foldable
+  (
+    for_
+  )
+import Data.Word
+  (
+    Word8
+  )
+import Foreign.C.Error
+  (
+    eXDEV
+  , eINVAL
+  , eNOSYS
+  )
+import Foreign.C.Types
+  (
+    CSize
+  )
+import Foreign.Marshal.Alloc
+  (
+    allocaBytes
+  )
+import Foreign.Ptr
+  (
+    Ptr
+  )
+import HPath
+  (
+    Path
+  , Abs
+  , Fn
+  )
+import qualified HPath as P
+import HSFM.FileSystem.Errors
+import HSFM.FileSystem.FileType
+import HSFM.Utils.IO
+import Prelude hiding (readFile, writeFile)
+import System.Posix.Directory.ByteString
+  (
+    createDirectory
+  , removeDirectory
+  )
+import System.Posix.Files.ByteString
+  (
+    createSymbolicLink
+  , fileMode
+  , getFdStatus
+  , groupExecuteMode
+  , groupReadMode
+  , groupWriteMode
+  , otherExecuteMode
+  , otherReadMode
+  , otherWriteMode
+  , ownerModes
+  , ownerReadMode
+  , ownerWriteMode
+  , readSymbolicLink
+  , removeLink
+  , rename
+  , unionFileModes
+  )
+import qualified System.Posix.Files.ByteString as PF
+import qualified "unix" System.Posix.IO.ByteString as SPI
+import qualified "unix-bytestring" System.Posix.IO.ByteString as SPB
+import System.Posix.IO.Sendfile.ByteString
+  (
+    sendfileFd
+  , FileRange(EntireFile)
+  )
+import qualified System.Posix.Process.ByteString as SPP
+import System.Posix.Types
+  (
+    ByteCount
+  , Fd
+  , FileMode
+  , ProcessID
+  )
+
+
+
+-- TODO: file operations should be threaded and not block the UI
+-- TODO: make sure we do the right thing for BlockDev, CharDev etc...
+--       most operations are not implemented for these
+
+
+-- |Data type describing an actual file operation that can be
+-- carried out via `doFile`. Useful to build up a list of operations
+-- or delay operations.
+data FileOperation = FCopy    Copy
+                   | FMove    Move
+                   | FDelete  [Path Abs]
+                   | FOpen    (Path Abs)
+                   | FExecute (Path Abs) [ByteString]
+                   | None
+
+
+-- |Data type describing partial or complete file copy operation.
+-- CC stands for a complete operation and can be used for `runFileOp`.
+data Copy = CP1 [Path Abs]
+          | CP2 [Path Abs]
+                (Path Abs)
+          | CC  [Path Abs]
+                (Path Abs)
+                CopyMode
+
+
+-- |Data type describing partial or complete file move operation.
+-- MC stands for a complete operation and can be used for `runFileOp`.
+data Move = MP1 [Path Abs]
+          | MC  [Path Abs]
+                (Path Abs)
+                CopyMode
+
+
+-- |Copy modes.
+data CopyMode = Strict  -- ^ fail if the target already exists
+              | Merge   -- ^ overwrite files if necessary, for files, this
+                        --   is the same as Replace
+              | Replace -- ^ remove targets before copying, this is
+                        --   only useful if the target is a directorty
+              | Rename (Path Fn)
+
+
+-- |Run a given FileOperation. If the FileOperation is partial, it will
+-- be returned. Returns `Nothing` on success.
+--
+-- Since file operations can be delayed, this is `Path Abs` based, not
+-- `File` based. This makes sure we don't have stale
+-- file information.
+runFileOp :: FileOperation -> IO (Maybe FileOperation)
+runFileOp fo' =
+  case fo' of
+    (FCopy (CC froms to cm)) -> do
+      froms' <- mapM toAfile froms
+      to'    <- toAfile to
+      when (anyFailed froms')
+           (throw . CopyFailed $ "File in copy buffer does not exist anymore!")
+      mapM_ (\x -> easyCopy cm x to') froms'
+        >> return Nothing
+    (FCopy fo) -> return $ Just $ FCopy fo
+    (FMove (MC froms to cm)) -> do
+      froms' <- mapM toAfile froms
+      to'   <- toAfile to
+      when (anyFailed froms')
+           (throw . MoveFailed $ "File in move buffer does not exist anymore!")
+      mapM_ (\x -> easyMove cm x to') froms'
+        >> return Nothing
+    (FMove fo) -> return $ Just $ FMove fo
+    (FDelete fps) -> do
+      fps' <- mapM toAfile fps
+      mapM_ easyDelete fps' >> return Nothing
+    (FOpen fp) ->
+      toAfile fp >>= openFile >> return Nothing
+    (FExecute fp args) ->
+      toAfile fp >>= flip executeFile args >> return Nothing
+    _ -> return Nothing
+  where
+    toAfile = readFile (\_ -> return undefined)
+
+
+
+    --------------------
+    --[ File Copying ]--
+    --------------------
+
+
+-- |Copies a directory to the given destination with the specified
+-- `DirCopyMode`. Excludes symlinks.
+copyDir :: CopyMode
+        -> File a  -- ^ source dir
+        -> File a  -- ^ destination dir
+        -> Path Fn -- ^ destination dir name
+        -> IO ()
+copyDir       (Rename fn)
+         from@Dir{}
+           to@Dir{}
+           _
+  = copyDir Strict from to fn
+-- this branch must never get `Rename` as CopyMode
+copyDir cm from@Dir{ path = fromp }
+             to@Dir{ path = top }
+             fn
+  = do
+    let destdirp = top P.</> fn
+    -- for performance, sanity checks are only done for the top dir
+    throwDestinationInSource fromp destdirp
+    throwSameFile fromp destdirp
+    throwCantOpenDirectory fromp
+    throwCantOpenDirectory top
+    go cm from to fn
+  where
+    go :: CopyMode -> File a -> File a -> Path Fn -> IO ()
+    go cm' Dir{ path = fromp' }
+           Dir{ path = top' }
+           fn' = do
+      fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus
+                                   (P.fromAbs fromp')
+      createDestdir (top' P.</> fn') fmode'
+      destdir <- readFile (\_ -> return undefined)
+                   (top' P.</> fn')
+      contents <- readDirectoryContents
+                    (\_ -> return undefined) fromp'
+
+      for_ contents $ \f ->
+        case f of
+          SymLink{ path = fp' }  -> recreateSymlink cm' f destdir
+                                      =<< (P.basename fp')
+          Dir{ path = fp' }      -> go cm' f destdir
+                                      =<< (P.basename fp')
+          RegFile{ path = fp' }  -> unsafeCopyFile Replace f destdir
+                                      =<< (P.basename fp')
+          _                      -> return ()
+      where
+        createDestdir destdir fmode' =
+          let destdir' = P.toFilePath destdir
+          in case cm' of
+            Merge   ->
+              unlessM (doesDirectoryExist destdir)
+                      (createDirectory destdir' fmode')
+            Strict  -> do
+              throwDirDoesExist destdir
+              createDirectory destdir' fmode'
+            Replace -> do
+              whenM (doesDirectoryExist destdir)
+                    (deleteDirRecursive =<<
+                       readFile
+                         (\_ -> return undefined) destdir)
+              createDirectory destdir' fmode'
+            _ -> throw $ InvalidOperation "Internal error, wrong CopyMode!"
+    go _ _ _ _ = throw $ InvalidOperation "wrong input type"
+copyDir _ _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Recreate a symlink.
+recreateSymlink :: CopyMode
+                -> File a  -- ^ the old symlink file
+                -> File a  -- ^ destination dir of the
+                           --   new symlink file
+                -> Path Fn -- ^ destination file name
+                -> IO ()
+recreateSymlink (Rename pn) symf@SymLink{} symdest@Dir{} _
+  = recreateSymlink Strict symf symdest pn
+recreateSymlink cm SymLink{ path = sfp } Dir{ path = sdp } fn
+  = do
+    throwCantOpenDirectory sdp
+    sympoint <- readSymbolicLink (P.fromAbs sfp)
+    let symname = sdp P.</> fn
+    case cm of
+      Merge   -> delOld symname
+      Replace -> delOld symname
+      _       -> return ()
+    createSymbolicLink sympoint (P.fromAbs symname)
+  where
+    delOld symname = do
+      f <- readFile (\_ -> return undefined) symname
+      unless (failed f)
+             (easyDelete f)
+recreateSymlink _ _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Copies the given regular file to the given dir with the given filename.
+-- Excludes symlinks.
+copyFile :: CopyMode
+         -> File a  -- ^ source file
+         -> File a  -- ^ destination dir
+         -> Path Fn -- ^ destination file name
+         -> IO ()
+copyFile (Rename pn) from@RegFile{} to@Dir{} _
+  = copyFile Strict from to pn
+copyFile cm from@RegFile{ path = fromp }
+             tod@Dir{ path = todp } fn
+  = do
+    throwCantOpenDirectory todp
+    throwCantOpenDirectory . P.dirname $ fromp
+    throwSameFile fromp (todp P.</> fn)
+    unsafeCopyFile cm from tod fn
+copyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Unsafe version of `copyFile` without initial sanity checks. This
+-- holds the actual copy logic though and is called by `copyFile` in the end.
+-- It's also used for cases where we don't need/want sanity checks
+-- and need the extra bit of performance.
+unsafeCopyFile :: CopyMode
+               -> File a  -- ^ source file
+               -> File a  -- ^ destination dir
+               -> Path Fn -- ^ destination file name
+               -> IO ()
+unsafeCopyFile (Rename pn) from@RegFile{} to@Dir{} _
+  = copyFile Strict from to pn
+unsafeCopyFile cm RegFile{ path = fromp }
+                  Dir{ path = todp } fn
+  = do
+    let to = todp P.</> fn
+    case cm of
+      Strict -> throwFileDoesExist to
+      _      -> return ()
+
+    -- from sendfile(2) manpage:
+    --   Applications  may  wish  to  fall back to read(2)/write(2) in the case
+    --   where sendfile() fails with EINVAL or ENOSYS.
+    P.withAbsPath to $ \to' -> P.withAbsPath fromp $ \from' ->
+      catchErrno [eINVAL, eNOSYS]
+                 (sendFileCopy from' to')
+                 (void $ fallbackCopy from' to')
+  where
+    -- this is low-level stuff utilizing sendfile(2) for speed
+    sendFileCopy source dest =
+      -- NOTE: we are not blocking IO here, O_NONBLOCK is false
+      -- for `defaultFileFlags`
+      bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags)
+              SPI.closeFd
+              $ \sfd -> do
+                fileM <- System.Posix.Files.ByteString.fileMode
+                         <$> getFdStatus sfd
+                bracket (SPI.openFd dest SPI.WriteOnly (Just fileM)
+                                    SPI.defaultFileFlags)
+                        SPI.closeFd
+                        $ \dfd -> sendfileFd dfd sfd EntireFile
+    -- low-level copy operation utilizing read(2)/write(2)
+    -- in case `sendFileCopy` fails/is unsupported
+    fallbackCopy source dest =
+      bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags)
+              SPI.closeFd
+              $ \sfd -> do
+                fileM <- System.Posix.Files.ByteString.fileMode
+                         <$> getFdStatus sfd
+                bracket (SPI.openFd dest SPI.WriteOnly (Just fileM)
+                                    SPI.defaultFileFlags)
+                        SPI.closeFd
+                        $ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf ->
+                                    write' sfd dfd buf 0
+      where
+        bufSize :: CSize
+        bufSize = 8192
+        write' :: Fd -> Fd -> Ptr Word8 -> Int -> IO Int
+        write' sfd dfd buf totalsize = do
+            size <- SPB.fdReadBuf sfd buf bufSize
+            if size == 0
+              then return $ fromIntegral totalsize
+              else do rsize <- SPB.fdWriteBuf dfd buf size
+                      when (rsize /= size) (throw . CopyFailed $ "wrong size!")
+                      write' sfd dfd buf (totalsize + fromIntegral size)
+unsafeCopyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Copies a regular file, directory or symlink. In case of a symlink,
+-- it is just recreated, even if it points to a directory.
+easyCopy :: CopyMode
+         -> File a
+         -> File a
+         -> IO ()
+easyCopy cm from@SymLink{}
+              to@Dir{}
+  = recreateSymlink cm from to =<< (P.basename . path $ from)
+easyCopy cm from@RegFile{}
+              to@Dir{}
+  = copyFile cm from to =<< (P.basename . path $ from)
+easyCopy cm from@Dir{}
+              to@Dir{}
+  = copyDir cm from to =<< (P.basename . path $ from)
+easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Write a ByteString to a file, overwriting the file. Follows
+-- symbolic links.
+writeFile :: File a -> ByteString -> IO ByteCount
+writeFile RegFile { path = fp } bs = P.withAbsPath fp $ \p ->
+  bracket (SPI.openFd p SPI.WriteOnly (Just PF.stdFileMode)
+             SPI.defaultFileFlags)
+          SPI.closeFd
+          $ \fd -> SPB.fdWrite fd bs
+writeFile SymLink { sdest = file@RegFile{} } bs =
+  writeFile file bs
+writeFile _ _ = throw $ InvalidOperation "wrong input type"
+
+
+readFileContents :: File FileInfo -> IO ByteString
+readFileContents RegFile { path = fp } =
+  P.withAbsPath fp $ \p ->
+    bracket (SPI.openFd p SPI.ReadOnly Nothing SPI.defaultFileFlags)
+            SPI.closeFd
+            $ \fd -> do
+              fs <- PF.getFdStatus fd
+              SPB.fdRead fd (fromIntegral $ PF.fileSize fs)
+readFileContents SymLink { sdest = file@RegFile{} } =
+  readFileContents file
+readFileContents _ = throw $ InvalidOperation "wrong input type"
+
+
+
+
+    ---------------------
+    --[ File Deletion ]--
+    ---------------------
+
+
+-- |Deletes a symlink, which can either point to a file or directory.
+deleteSymlink :: File a -> IO ()
+deleteSymlink SymLink{ path = fp }
+  = P.withAbsPath fp removeLink
+deleteSymlink _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Deletes the given regular file, never symlinks.
+deleteFile :: File a -> IO ()
+deleteFile RegFile{ path = fp }
+  = P.withAbsPath fp removeLink
+deleteFile _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Deletes the given directory, never symlinks.
+deleteDir :: File a -> IO ()
+deleteDir Dir{ path = fp }
+  = P.withAbsPath fp removeDirectory
+deleteDir _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Deletes the given directory recursively.
+deleteDirRecursive :: File a -> IO ()
+deleteDirRecursive f'@Dir{ path = fp' } = do
+  throwCantOpenDirectory fp'
+  go f'
+  where
+    go :: File a -> IO ()
+    go Dir{ path = fp } = do
+      files <- readDirectoryContents
+                 (\_ -> return undefined) fp
+      for_ files $ \file ->
+        case file of
+          SymLink{} -> deleteSymlink file
+          Dir{}     -> go file
+          RegFile{ path = rfp }
+                    -> P.withAbsPath rfp removeLink
+          _         -> throw $ FileDoesExist
+                               (P.toFilePath . path $ file)
+      removeDirectory . P.toFilePath $ fp
+    go _ = throw $ InvalidOperation "wrong input type"
+deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Deletes a file, directory or symlink, whatever it may be.
+-- In case of directory, performs recursive deletion. In case of
+-- a symlink, the symlink file is deleted.
+easyDelete :: File a -> IO ()
+easyDelete f@SymLink{} = deleteSymlink f
+easyDelete f@RegFile{}
+  = deleteFile f
+easyDelete f@Dir{}
+  = deleteDirRecursive f
+easyDelete _ = throw $ InvalidOperation "wrong input type"
+
+
+
+
+    --------------------
+    --[ File Opening ]--
+    --------------------
+
+
+-- |Opens a file appropriately by invoking xdg-open. The file type
+-- is not checked.
+openFile :: File a
+         -> IO ProcessID
+openFile f =
+  P.withAbsPath (path f) $ \fp ->
+    SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
+
+
+-- |Executes a program with the given arguments.
+executeFile :: File a  -- ^ program
+            -> [ByteString]    -- ^ arguments
+            -> IO ProcessID
+executeFile RegFile{ path = fp } args
+  = P.withAbsPath fp $ \fpb ->
+      SPP.forkProcess
+      $ SPP.executeFile fpb True args Nothing
+executeFile SymLink{ path = fp, sdest = RegFile{} } args
+  = P.withAbsPath fp $ \fpb ->
+      SPP.forkProcess
+      $ SPP.executeFile fpb True args Nothing
+executeFile _ _ = throw $ InvalidOperation "wrong input type"
+
+
+
+
+    ---------------------
+    --[ File Creation ]--
+    ---------------------
+
+
+-- |Create an empty regular file at the given directory with the given filename.
+createFile :: File FileInfo -> Path Fn -> IO ()
+createFile (DirOrSym td) fn = do
+  let fullp = path td P.</> fn
+  throwFileDoesExist fullp
+  fd <- SPI.createFile (P.fromAbs fullp) newFilePerms
+  SPI.closeFd fd
+createFile _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Create an empty directory at the given directory with the given filename.
+createDir :: File FileInfo -> Path Fn -> IO ()
+createDir (DirOrSym td) fn = do
+  let fullp = path td P.</> fn
+  throwDirDoesExist fullp
+  createDirectory (P.fromAbs fullp) newDirPerms
+createDir _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Create a directory at the given path, creating all parents if
+-- necessary.
+mkdirP :: Path Abs -> IO ()
+mkdirP p = do
+  mkps <- dropWhileM canOpenDirectory (reverse $ p : P.getAllParents p)
+  forM_ mkps $ \mkp -> createDirectory (P.fromAbs mkp) newDirPerms
+
+
+
+
+    ----------------------------
+    --[ File Renaming/Moving ]--
+    ----------------------------
+
+
+-- |Rename a given file with the provided filename.
+renameFile :: File a -> Path Fn -> IO ()
+renameFile af fn = do
+  let fromf = path af
+      tof   = (P.dirname . path $ af) P.</> fn
+  throwFileDoesExist tof
+  throwSameFile fromf tof
+  rename (P.fromAbs fromf) (P.fromAbs tof)
+
+
+-- |Move a given file to the given target directory.
+moveFile :: CopyMode
+         -> File a  -- ^ file to move
+         -> File a  -- ^ base target directory
+         -> Path Fn -- ^ target file name
+         -> IO ()
+moveFile (Rename pn) from to@Dir{} _ =
+  moveFile Strict from to pn
+moveFile cm from to@Dir{} fn = do
+  let from'  = path from
+      froms' = P.fromAbs from'
+      to'    = path to P.</> fn
+      tos'   = P.fromAbs to'
+  case cm of
+    Strict   -> throwFileDoesExist to'
+    Merge    -> delOld to'
+    Replace  -> delOld to'
+    Rename _ -> throw $ InvalidOperation "Internal error! Wrong CopyMode!"
+  throwSameFile from' to'
+  catchErrno [eXDEV] (rename froms' tos') $ do
+    easyCopy Strict from to
+    easyDelete from
+  where
+    delOld fp = do
+      to' <- readFile (\_ -> return undefined) fp
+      unless (failed to') (easyDelete to')
+moveFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
+
+
+-- |Like `moveFile` except it uses the filename of the source as target.
+easyMove :: CopyMode
+         -> File a -- ^ file to move
+         -> File a -- ^ base target directory
+         -> IO ()
+easyMove cm from to = moveFile cm from to =<< (P.basename . path $ from)
+
+
+
+    -----------------------
+    --[ File Permissions]--
+    -----------------------
+
+
+-- |Default permissions for a new file.
+newFilePerms :: FileMode
+newFilePerms
+  =                  ownerWriteMode
+    `unionFileModes` ownerReadMode
+    `unionFileModes` groupWriteMode
+    `unionFileModes` groupReadMode
+    `unionFileModes` otherWriteMode
+    `unionFileModes` otherReadMode
+
+
+-- |Default permissions for a new directory.
+newDirPerms :: FileMode
+newDirPerms
+  =                  ownerModes
+    `unionFileModes` groupExecuteMode
+    `unionFileModes` groupReadMode
+    `unionFileModes` otherExecuteMode
+    `unionFileModes` otherReadMode
+

src/HSFM/FileSystem/FileType.hs

@@ -18,45 +18,39 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
-
+-- |This module provides data types for representing directories/files
--- |This module provides a data type for representing directories/files
+-- and related operations on it, mostly internal stuff.
--- in a well-typed and convenient way. This is useful to gather and
--- save information about a file, so the information can be easily
--- processed in e.g. a GUI.
 --
--- However, it's not meant to be used to interact with low-level
+-- It doesn't allow to represent the whole filesystem, since that's only
--- functions that copy files etc, since there's no guarantee that
+-- possible through IO laziness, which introduces too much internal state.
--- the in-memory representation of the type still matches what is
--- happening on filesystem level.
---
--- If you interact with low-level libraries, you must not pattern
--- match on the `File a` type. Instead, you should only use the saved
--- `path` and make no assumptions about the file the path might or
--- might not point to.
 module HSFM.FileSystem.FileType where
 
 
 
 import Data.ByteString(ByteString)
-import Data.ByteString.UTF8
-  (
-    toString
-  )
 import Data.Default
+import Data.Maybe
+  (
+    catMaybes
+  )
 import Data.Time.Clock.POSIX
   (
     POSIXTime
   , posixSecondsToUTCTime
   )
 import Data.Time()
+import Foreign.C.Error
+  (
+    eACCES
+  )
 import HPath
   (
     Abs
   , Path
+  , Fn
   )
 import qualified HPath as P
-import HPath.IO hiding (FileType(..))
+import HSFM.FileSystem.Errors
-import HPath.IO.Errors
 import HSFM.Utils.MyPrelude
 import Prelude hiding(readFile)
 import System.IO.Error
@@ -70,7 +64,8 @@ import System.Posix.FilePath
   )
 import System.Posix.Directory.Traversals
   (
-    realpath
+    getDirectoryContents
+  , realpath
   )
 import qualified System.Posix.Files.ByteString as PF
 import System.Posix.Types
@@ -98,7 +93,8 @@ import System.Posix.Types
 -- |The String in the path field is always a full path.
 -- The free type variable is used in the File/Dir constructor and can hold
 -- Handles, Strings representing a file's contents or anything else you can
--- think of. We catch any IO errors in the Failed constructor.
+-- think of. We catch any IO errors in the Failed constructor. an Exception
+-- can be converted to a String with 'show'.
 data File a =
     Failed {
     path :: !(Path Abs)
@@ -341,10 +337,10 @@ readDirectoryContents :: (Path Abs -> IO a)  -- ^ fills free a variable
 readDirectoryContents ff p = do
   files <- getDirsFiles p
   fcs   <- mapM (readFile ff) files
-  return fcs
+  return $ removeNonexistent fcs
 
 
--- |A variant of `readDirectoryContents` where the second argument
+-- |A variant of `readDirectoryContents` where the third argument
 -- is a `File`. If a non-directory is passed returns an empty list.
 getContents :: (Path Abs -> IO a)
             -> File FileInfo
@@ -465,7 +461,19 @@ isSocketC _        = False
 ---- IO HELPERS: ----
 
 
-
+-- |Gets all filenames of the given directory. This excludes "." and "..".
+getDirsFiles :: Path Abs        -- ^ dir to read
+             -> IO [Path Abs]
+getDirsFiles p =
+  P.withAbsPath p $ \fp ->
+    rethrowErrnoAs [eACCES] (Can'tOpenDirectory fp)
+    $ return
+        . catMaybes
+        .   fmap (\x -> (P.</>) p <$> (parseMaybe . snd $ x))
+        =<< getDirectoryContents fp
+  where
+    parseMaybe :: ByteString -> Maybe (Path Fn)
+    parseMaybe = P.parseFn
 
 
 -- |Gets all file information.
@@ -502,6 +510,18 @@ handleDT p
   = handleIOError $ \e -> return $ Failed p e
 
 
+-- DoesNotExist errors not present at the topmost level could happen if a
+-- named file or directory is deleted after being listed by
+-- getDirectoryContents but before we can get it into memory.
+--    So we filter those errors out because the user should not see errors
+-- raised by the internal implementation of this module:
+--    This leaves the error if it exists in the top (user-supplied) level:
+removeNonexistent :: [File a] -> [File a]
+removeNonexistent = filter isOkConstructor
+  where
+    isOkConstructor c = not (failed c) || isOkError c
+    isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
+
 
 ---- SYMLINK HELPERS: ----
 
@@ -515,9 +535,29 @@ isBrokenSymlink (SymLink _ _ Failed{} _) = True
 isBrokenSymlink _ = False
 
 
+---- OTHER: ----
 
 
----- PACKERS: ----
+-- |Apply a function on the free variable. If there is no free variable
+-- for the given constructor the value from the `Default` class is used.
+fromFreeVar :: (Default d) => (a -> d) -> File a -> d
+fromFreeVar f df = maybeD f $ getFreeVar df
+
+
+getFPasStr :: File a -> String
+getFPasStr = P.fpToString . P.fromAbs . path
+
+
+-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
+getFreeVar :: File a -> Maybe a
+getFreeVar (Dir _  d)         = Just d
+getFreeVar (RegFile _  d)     = Just d
+getFreeVar (SymLink _  d _ _) = Just d
+getFreeVar (BlockDev _  d)    = Just d
+getFreeVar (CharDev _  d)     = Just d
+getFreeVar (NamedPipe _  d)   = Just d
+getFreeVar (Socket _  d)      = Just d
+getFreeVar _                  = Nothing
 
 
 -- |Pack the modification time into a string.
@@ -585,30 +625,3 @@ packLinkDestination file = case file of
   SymLink { rawdest = dest } -> Just dest
   _                          -> Nothing
 
-
-
-
----- OTHER: ----
-
-
--- |Apply a function on the free variable. If there is no free variable
--- for the given constructor the value from the `Default` class is used.
-fromFreeVar :: (Default d) => (a -> d) -> File a -> d
-fromFreeVar f df = maybeD f $ getFreeVar df
-
-
-getFPasStr :: File a -> String
-getFPasStr = toString . P.fromAbs . path
-
-
--- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
-getFreeVar :: File a -> Maybe a
-getFreeVar (Dir _  d)         = Just d
-getFreeVar (RegFile _  d)     = Just d
-getFreeVar (SymLink _  d _ _) = Just d
-getFreeVar (BlockDev _  d)    = Just d
-getFreeVar (CharDev _  d)     = Just d
-getFreeVar (NamedPipe _  d)   = Just d
-getFreeVar (Socket _  d)      = Just d
-getFreeVar _                  = Nothing
-

src/HSFM/FileSystem/UtilTypes.hs

@@ -1,84 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-
--- |This module provides high-level IO related file operations like
--- copy, delete, move and so on. It only operates on `Path Abs` which
--- guarantees us well-typed paths which are absolute.
---
--- Some functions are just path-safe wrappers around
--- unix functions, others have stricter exception handling
--- and some implement functionality that doesn't have a unix
--- counterpart (like `copyDirRecursive`).
---
--- Some of these operations are due to their nature not _atomic_, which
--- means they may do multiple syscalls which form one context. Some
--- of them also have to examine the filetypes explicitly before the
--- syscalls, so a reasonable decision can be made. That means
--- the result is undefined if another process changes that context
--- while the non-atomic operation is still happening. However, where
--- possible, as few syscalls as possible are used and the underlying
--- exception handling is kept.
-module HSFM.FileSystem.UtilTypes where
-
-
-import Data.ByteString
-  (
-    ByteString
-  )
-import HPath
-  (
-    Path
-  , Abs
-  , Fn
-  )
-
-
--- |Data type describing file operations.
--- Useful to build up a list of operations or delay operations.
-data FileOperation = FCopy    Copy
-                   | FMove    Move
-                   | FDelete  [Path Abs]
-                   | FOpen    (Path Abs)
-                   | FExecute (Path Abs) [ByteString]
-                   | None
-
-
--- |Data type describing partial or complete file copy operation.
-data Copy = PartialCopy [Path Abs] -- source files
-          | Copy        [Path Abs] -- source files
-                        (Path Abs) -- base destination directory
-
-
--- |Data type describing partial or complete file move operation.
-data Move = PartialMove [Path Abs] -- source files
-          | Move        [Path Abs] -- source files
-                        (Path Abs) -- base destination directory
-
-
--- |Collision modes that describe the behavior in case a file collision
--- happens.
-data FCollisonMode = Strict  -- ^ fail if the target already exists
-                   | Overwrite
-                   | OverwriteAll
-                   | Skip
-                   | Rename (Path Fn)
-

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -28,7 +28,7 @@ import Control.Concurrent.STM
   )
 import Control.Exception
   (
-    throwIO
+    throw
   )
 import Control.Monad
   (
@@ -40,15 +40,6 @@ import Control.Monad.IO.Class
   (
     liftIO
   )
-import Data.ByteString
-  (
-    ByteString
-  )
-import Data.ByteString.UTF8
-  (
-    fromString
-  , toString
-  )
 import Data.Foldable
   (
     for_
@@ -60,12 +51,9 @@ import HPath
       Abs
     , Path
     )
-import HPath.IO
+import HSFM.FileSystem.Errors
-import HPath.IO.Errors
+import HSFM.FileSystem.FileOperations
-import HPath.IO.Utils
 import HSFM.FileSystem.FileType
-import HSFM.FileSystem.UtilTypes
-import HSFM.GUI.Gtk.Callbacks.Utils
 import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.Dialogs
 import HSFM.GUI.Gtk.MyView
@@ -339,21 +327,21 @@ del :: [Item] -> MyGUI -> MyView -> IO ()
 del [item] _ _ = withErrorDialog $ do
   let cmsg  = "Really delete \"" ++ getFPasStr item ++ "\"?"
   withConfirmationDialog cmsg
-    $ easyDelete . path $ item
+    $ easyDelete item
 -- this throws on the first error that occurs
 del items@(_:_) _ _ = withErrorDialog $ do
   let cmsg  = "Really delete " ++ show (length items) ++ " files?"
   withConfirmationDialog cmsg
-    $ forM_ items $ \item -> easyDelete . path $ item
+    $ forM_ items $ \item -> easyDelete item
 del _ _ _ = withErrorDialog
-              . throwIO $ InvalidOperation
+              . throw $ InvalidOperation
-                          "Operation not supported on multiple files"
+                        "Operation not supported on multiple files"
 
 
 -- |Initializes a file move operation.
 moveInit :: [Item] -> MyGUI -> MyView -> IO ()
 moveInit items@(_:_) mygui _ = do
-  writeTVarIO (operationBuffer mygui) (FMove . PartialMove . map path $ items)
+  writeTVarIO (operationBuffer mygui) (FMove . MP1 . map path $ items)
   let sbmsg = case items of
               (item:[]) -> "Move buffer: " ++ getFPasStr item
               _         -> "Move buffer: " ++ (show . length $ items)
@@ -361,13 +349,13 @@ moveInit items@(_:_) mygui _ = do
   popStatusbar mygui
   void $ pushStatusBar mygui sbmsg
 moveInit _ _ _ = withErrorDialog
-                   . throwIO $ InvalidOperation
+                   . throw $ InvalidOperation
-                               "No file selected!"
+                             "No file selected!"
 
 -- |Supposed to be used with 'withRows'. Initializes a file copy operation.
 copyInit :: [Item] -> MyGUI -> MyView -> IO ()
 copyInit items@(_:_) mygui _ = do
-  writeTVarIO (operationBuffer mygui) (FCopy . PartialCopy . map path $ items)
+  writeTVarIO (operationBuffer mygui) (FCopy . CP1 . map path $ items)
   let sbmsg = case items of
               (item:[]) -> "Copy buffer: " ++ getFPasStr item
               _         -> "Copy buffer: " ++ (show . length $ items)
@@ -375,8 +363,8 @@ copyInit items@(_:_) mygui _ = do
   popStatusbar mygui
   void $ pushStatusBar mygui sbmsg
 copyInit _ _ _ = withErrorDialog
-                   . throwIO $ InvalidOperation
+                   . throw $ InvalidOperation
-                               "No file selected!"
+                             "No file selected!"
 
 
 -- |Finalizes a file operation, such as copy or move.
@@ -387,61 +375,62 @@ operationFinal mygui myview mitem = withErrorDialog $ do
             Nothing -> path <$> getCurrentDir myview
             Just x  -> return $ path x
   case op of
-    FMove (PartialMove s) -> do
+    FMove (MP1 s) -> do
       let cmsg = "Really move " ++ imsg s
-                  ++ " to \"" ++ toString (P.fromAbs cdir)
+                  ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
                   ++ "\"?"
-      withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
+      withConfirmationDialog cmsg . withCopyModeDialog
-      popStatusbar mygui
+        $ \cm -> do
-      writeTVarIO (operationBuffer mygui) None
+             void $ runFileOp (FMove . MC s cdir $ cm)
-    FCopy (PartialCopy s) -> do
+             popStatusbar mygui
+             writeTVarIO (operationBuffer mygui) None
+    FCopy (CP1 s) -> do
       let cmsg = "Really copy " ++ imsg s
-                 ++ " to \"" ++ toString (P.fromAbs cdir)
+                 ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
                  ++ "\"?"
-      withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir)
+      withConfirmationDialog cmsg . withCopyModeDialog
+        $ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
     _ -> return ()
   where
     imsg s = case s of
-               (item:[]) -> "\"" ++ toString (P.fromAbs item) ++ "\""
+               (item:[]) -> "\"" ++ P.fpToString (P.fromAbs item) ++ "\""
                items     -> (show . length $ items) ++ " items"
 
 
 -- |Create a new file.
 newFile :: MyGUI -> MyView -> IO ()
 newFile _ myview = withErrorDialog $ do
-  mfn   <- textInputDialog "Enter file name" ("" :: String)
+  mfn   <- textInputDialog "Enter file name"
-  let pmfn = P.parseFn =<< fromString <$> mfn
+  let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
   for_ pmfn $ \fn -> do
     cdir  <- getCurrentDir myview
-    createRegularFile (path cdir P.</> fn)
+    createFile cdir fn
 
 
 -- |Create a new directory.
 newDir :: MyGUI -> MyView -> IO ()
 newDir _ myview = withErrorDialog $ do
-  mfn   <- textInputDialog "Enter directory name" ("" :: String)
+  mfn   <- textInputDialog "Enter directory name"
-  let pmfn = P.parseFn =<< fromString <$> mfn
+  let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
   for_ pmfn $ \fn -> do
     cdir  <- getCurrentDir myview
-    createDir (path cdir P.</> fn)
+    createDir cdir fn
 
 
 renameF :: [Item] -> MyGUI -> MyView -> IO ()
 renameF [item] _ _ = withErrorDialog $ do
-  iname <- P.fromRel <$> (P.basename $ path item)
+  mfn  <- textInputDialog "Enter new file name"
-  mfn  <- textInputDialog "Enter new file name" (iname :: ByteString)
+  let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
-  let pmfn = P.parseFn =<< fromString <$> mfn
   for_ pmfn $ \fn -> do
     let cmsg = "Really rename \"" ++ getFPasStr item
                ++ "\"" ++ " to \""
-               ++ toString (P.fromAbs $ (P.dirname . path $ item)
+               ++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
                                              P.</> fn) ++ "\"?"
     withConfirmationDialog cmsg $
-      HPath.IO.renameFile (path item)
+      HSFM.FileSystem.FileOperations.renameFile item fn
-                          ((P.dirname $ path item) P.</> fn)
 renameF _ _ _ = withErrorDialog
-                  . throwIO $ InvalidOperation
+                  . throw $ InvalidOperation
-                              "Operation not supported on multiple files"
+                            "Operation not supported on multiple files"
 
 
 
@@ -472,10 +461,10 @@ goHome mygui myview =  withErrorDialog $ do
 -- |Execute a given file.
 execute :: [Item] -> MyGUI -> MyView -> IO ()
 execute [item] _ _ = withErrorDialog $
-  void $ executeFile (path item) []
+  void $ executeFile item []
 execute _ _ _ = withErrorDialog
-                  . throwIO $ InvalidOperation
+                  . throw $ InvalidOperation
-                              "Operation not supported on multiple files"
+                            "Operation not supported on multiple files"
 
 
 -- |Supposed to be used with 'withRows'. Opens a file or directory.
@@ -486,13 +475,13 @@ open [item] mygui myview = withErrorDialog $
       nv <- readFile getFileInfo $ path r
       goDir mygui myview nv
     r ->
-      void $ openFile . path $ r
+      void $ openFile r
 -- this throws on the first error that occurs
 open (FileLikeList fs) _ _ = withErrorDialog $
-  forM_ fs $ \f -> void $ openFile . path $ f
+  forM_ fs $ \f -> void $ openFile f
 open _ _ _ = withErrorDialog
-               . throwIO $ InvalidOperation
+               . throw $ InvalidOperation
-                           "Operation not supported on multiple files"
+                         "Operation not supported on multiple files"
 
 
 -- |Go up one directory and visualize it in the treeView.
@@ -503,6 +492,15 @@ upDir mygui myview = withErrorDialog $ do
   goDir mygui myview nv
 
 
+-- |Helper that is invoked for any directory change operations.
+goDir :: MyGUI -> MyView -> Item -> IO ()
+goDir mygui myview item = do
+  cdir <- getCurrentDir myview
+  modifyTVarIO (history myview)
+    (\(p, _) -> (path cdir `addHistory` p, []))
+  refreshView' mygui myview item
+
+
 -- |Go "back" in the history.
 goHistoryPrev :: MyGUI -> MyView -> IO ()
 goHistoryPrev mygui myview = do

src/HSFM/GUI/Gtk/Callbacks/Utils.hs

@@ -1,110 +0,0 @@
-{--
-HSFM, a filemanager written in Haskell.
-Copyright (C) 2016 Julian Ospald
-
-This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License
-version 2 as published by the Free Software Foundation.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
---}
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_HADDOCK ignore-exports #-}
-
-module HSFM.GUI.Gtk.Callbacks.Utils where
-
-
-
-import Control.Monad
-  (
-    forM
-  , forM_
-  )
-import Control.Monad.IO.Class
-  (
-    liftIO
-  )
-import GHC.IO.Exception
-  (
-    IOErrorType(..)
-  )
-import Graphics.UI.Gtk
-import qualified HPath as P
-import HPath.IO
-import HPath.IO.Errors
-import HSFM.FileSystem.FileType
-import HSFM.FileSystem.UtilTypes
-import HSFM.GUI.Gtk.Data
-import HSFM.GUI.Gtk.Dialogs
-import HSFM.GUI.Gtk.MyView
-import HSFM.GUI.Gtk.Utils
-import HSFM.Utils.IO
-  (
-    modifyTVarIO
-  )
-import Prelude hiding(readFile)
-import Control.Concurrent.STM.TVar
-  (
-    readTVarIO
-  )
-
-
-
-
--- |Carries out a file operation with the appropriate error handling
--- allowing the user to react to various exceptions with further input.
-doFileOperation :: FileOperation -> IO ()
-doFileOperation (FCopy (Copy (f':fs') to)) =
-  _doFileOperation (f':fs') to easyCopyOverwrite easyCopy
-    $ doFileOperation (FCopy $ Copy fs' to)
-doFileOperation (FMove (Move (f':fs') to)) =
-  _doFileOperation (f':fs') to moveFileOverwrite moveFile
-    $ doFileOperation (FMove $ Move fs' to)
-doFileOperation _ = return ()
-
-
-_doFileOperation :: [P.Path b1]
-                 -> P.Path P.Abs
-                 -> (P.Path b1 -> P.Path P.Abs -> IO b)
-                 -> (P.Path b1 -> P.Path P.Abs -> IO a)
-                 -> IO ()
-                 -> IO ()
-_doFileOperation [] _ _ _ _ = return ()
-_doFileOperation (f:fs) to mcOverwrite mc rest = do
-  toname <- P.basename f
-  let topath = to P.</> toname
-  reactOnError (mc f topath >> rest)
-    [(AlreadyExists  , collisionAction fileCollisionDialog topath)]
-    [(FileDoesExist{}, collisionAction fileCollisionDialog topath)
-    ,(DirDoesExist{} , collisionAction fileCollisionDialog topath)
-    ,(SameFile{}     , collisionAction renameDialog topath)]
-  where
-    collisionAction diag topath = do
-      mcm <- diag . P.fromAbs $ topath
-      forM_ mcm $ \cm -> case cm of
-        Overwrite    -> mcOverwrite f topath >> rest
-        OverwriteAll -> forM_ (f:fs) $ \x -> do
-                          toname' <- P.basename x
-                          mcOverwrite x (to P.</> toname')
-        Skip         -> rest
-        Rename newn  -> mc f (to P.</> newn) >> rest
-        _            -> return ()
-
-
--- |Helper that is invoked for any directory change operations.
-goDir :: MyGUI -> MyView -> Item -> IO ()
-goDir mygui myview item = do
-  cdir <- getCurrentDir myview
-  modifyTVarIO (history myview)
-    (\(p, _) -> (path cdir `addHistory` p, []))
-  refreshView' mygui myview item
-

src/HSFM/GUI/Gtk/Data.hs

@@ -35,9 +35,9 @@ import HPath
     Abs
   , Path
   )
+import HSFM.FileSystem.FileOperations
 import HSFM.FileSystem.FileType
-import HSFM.FileSystem.UtilTypes
+import System.INotify.ByteString
-import System.INotify
   (
     INotify
   )

src/HSFM/GUI/Gtk/Dialogs.hs

@@ -21,14 +21,11 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 module HSFM.GUI.Gtk.Dialogs where
 
 
-import Control.Applicative
-  (
-    (<$>)
-  )
 import Control.Exception
   (
-    displayException
+    catch
-  , throwIO
+  , displayException
+  , throw
   , IOException
   , catches
   , Handler(..)
@@ -39,15 +36,7 @@ import Control.Monad
   , when
   , void
   )
-import Data.ByteString
-  (
-    ByteString
-  )
 import qualified Data.ByteString as BS
-import Data.ByteString.UTF8
-  (
-    fromString
-  )
 import Data.Version
   (
     showVersion
@@ -72,9 +61,9 @@ import Distribution.Verbosity
   )
 import Graphics.UI.Gtk
 import qualified HPath as P
-import HPath.IO.Errors
+import HSFM.FileSystem.Errors
+import HSFM.FileSystem.FileOperations
 import HSFM.FileSystem.FileType
-import HSFM.FileSystem.UtilTypes
 import HSFM.GUI.Glib.GlibString()
 import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.Errors
@@ -82,18 +71,6 @@ import Paths_hsfm
   (
     getDataFileName
   )
-import System.Glib.UTFString
-  (
-    GlibString
-  )
-import System.Posix.FilePath
-  (
-    takeFileName
-  )
-
-
-
-
 
 
 
@@ -131,58 +108,76 @@ showConfirmationDialog str = do
     _           -> return False
 
 
-fileCollisionDialog :: ByteString -> IO (Maybe FCollisonMode)
+-- |Asks the user which directory copy mode he wants via dialog popup
-fileCollisionDialog t = do
+-- and returns 'DirCopyMode'. Default is always Strict, so this allows
+-- switching to Merge/Replace/Rename.
+showCopyModeDialog :: IO (Maybe CopyMode)
+showCopyModeDialog = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
-                                    (fromString "Target \"" `BS.append`
+                                    "Target exists, how to proceed?"
-                                     t `BS.append`
+  _ <- dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
-                                     fromString "\" exists, how to proceed?")
+  _ <- dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
-  _ <- dialogAddButton chooserDialog "Cancel"        (ResponseUser 0)
+  _ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2)
-  _ <- dialogAddButton chooserDialog "Overwrite"     (ResponseUser 1)
+  _ <- dialogAddButton chooserDialog "Rename"  (ResponseUser 3)
-  _ <- dialogAddButton chooserDialog "Overwrite all" (ResponseUser 2)
-  _ <- dialogAddButton chooserDialog "Skip"          (ResponseUser 3)
-  _ <- dialogAddButton chooserDialog "Rename"        (ResponseUser 4)
   rID <- dialogRun chooserDialog
   widgetDestroy chooserDialog
   case rID of
     ResponseUser 0 -> return Nothing
-    ResponseUser 1 -> return (Just Overwrite)
+    ResponseUser 1 -> return (Just Merge)
-    ResponseUser 2 -> return (Just OverwriteAll)
+    ResponseUser 2 -> return (Just Replace)
-    ResponseUser 3 -> return (Just Skip)
+    ResponseUser 3 -> do
-    ResponseUser 4 -> do
+      mfn   <- textInputDialog "Enter new name"
-      mfn   <- textInputDialog (fromString "Enter new name") (takeFileName t)
       forM mfn $ \fn -> do
-        pfn <- P.parseFn (fromString fn)
+        pfn <- P.parseFn (P.userStringToFP fn)
         return $ Rename pfn
-    _              -> throwIO UnknownDialogButton
+    _              -> throw  UnknownDialogButton
 
 
-renameDialog :: ByteString -> IO (Maybe FCollisonMode)
+-- |Stipped version of `showCopyModeDialog` that only allows cancelling
-renameDialog t = do
+-- or Renaming.
+showRenameDialog :: IO (Maybe CopyMode)
+showRenameDialog = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
-                                    (fromString "Target \"" `BS.append`
+                                    "Target exists, how to proceed?"
-                                     t `BS.append`
+  _ <- dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
-                                     fromString "\" exists, how to proceed?")
+  _ <- dialogAddButton chooserDialog "Rename"  (ResponseUser 1)
-  _ <- dialogAddButton chooserDialog "Cancel"        (ResponseUser 0)
-  _ <- dialogAddButton chooserDialog "Skip"          (ResponseUser 1)
-  _ <- dialogAddButton chooserDialog "Rename"        (ResponseUser 2)
   rID <- dialogRun chooserDialog
   widgetDestroy chooserDialog
   case rID of
     ResponseUser 0 -> return Nothing
-    ResponseUser 1 -> return (Just Skip)
+    ResponseUser 1 -> do
-    ResponseUser 2 -> do
+      mfn   <- textInputDialog "Enter new name"
-      mfn   <- textInputDialog (fromString "Enter new name") (takeFileName t)
       forM mfn $ \fn -> do
-        pfn <- P.parseFn (fromString fn)
+        pfn <- P.parseFn (P.userStringToFP fn)
         return $ Rename pfn
-    _              -> throwIO UnknownDialogButton
+    _              -> throw  UnknownDialogButton
+
+
+-- |Attempts to run the given function with the `Strict` copy mode.
+-- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
+-- the user for action via `showCopyModeDialog` and then carries out
+-- the given function again.
+withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
+withCopyModeDialog fa =
+  catch (fa Strict) $ \e ->
+    case e of
+      FileDoesExist _ -> doIt showCopyModeDialog
+      DirDoesExist  _ -> doIt showCopyModeDialog
+      SameFile _ _    -> doIt showRenameDialog
+      e'              -> throw e'
+  where
+    doIt getCm = do
+      mcm <- getCm
+      case mcm of
+        (Just Strict) -> return () -- don't try again
+        (Just cm)     -> fa cm
+        Nothing       -> return ()
 
 
 -- |Shows the about dialog from the help menu.
@@ -226,24 +221,20 @@ withErrorDialog io =
     [ Handler (\e -> showErrorDialog
                        $ displayException (e :: IOException))
     , Handler (\e -> showErrorDialog
-                       $ displayException (e :: HPathIOException))
+                       $ displayException (e :: FmIOException))
     ]
 
 
 -- |Asks the user which directory copy mode he wants via dialog popup
 -- and returns 'DirCopyMode'.
-textInputDialog :: GlibString string
+textInputDialog :: String -> IO (Maybe String)
-                => string   -- ^ window title
+textInputDialog title = do
-                -> string   -- ^ initial text in input widget
-                -> IO (Maybe String)
-textInputDialog title inittext = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
                                     title
   entry <- entryNew
-  entrySetText entry inittext
   cbox <- dialogGetActionArea chooserDialog
   _ <- dialogAddButton chooserDialog "Ok"     (ResponseUser 0)
   _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
@@ -254,7 +245,7 @@ textInputDialog title inittext = do
            -- TODO: make this more safe
            ResponseUser 0 -> Just <$> entryGetText entry
            ResponseUser 1 -> return Nothing
-           _              -> throwIO UnknownDialogButton
+           _              -> throw  UnknownDialogButton
   widgetDestroy chooserDialog
   return ret
 

src/HSFM/GUI/Gtk/Errors.hs

@@ -16,7 +16,6 @@ along with this program; if not, write to the Free Software
 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 --}
 
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
 -- |Provides error handling for Gtk.

src/HSFM/GUI/Gtk/Icons.hs

@@ -22,10 +22,6 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 module HSFM.GUI.Gtk.Icons where
 
 
-import Control.Applicative
-  (
-    (<$>)
-  )
 import Data.Maybe
   (
     fromJust

src/HSFM/GUI/Gtk/MyGUI.hs

@@ -27,7 +27,7 @@ import Control.Concurrent.STM
     newTVarIO
   )
 import Graphics.UI.Gtk
-import HSFM.FileSystem.UtilTypes
+import HSFM.FileSystem.FileOperations
 import HSFM.GUI.Gtk.Data
 import Paths_hsfm
   (

src/HSFM/GUI/Gtk/MyView.hs

@@ -16,15 +16,12 @@ along with this program; if not, write to the Free Software
 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 --}
 
+{-# OPTIONS_HADDOCK ignore-exports #-}
 
 
 module HSFM.GUI.Gtk.MyView where
 
 
-import Control.Applicative
-  (
-    (<$>)
-  )
 import Control.Concurrent.MVar
   (
     newEmptyMVar
@@ -41,11 +38,6 @@ import Control.Exception
     try
   , SomeException
   )
-import Control.Monad
-  (
-    forM_
-  )
-import qualified Data.ByteString as BS
 import Data.Foldable
   (
     for_
@@ -55,7 +47,7 @@ import Data.Maybe
     catMaybes
   , fromJust
   )
-import HPath.IO.Errors
+import HSFM.FileSystem.Errors
   (
     canOpenDirectory
   )
@@ -78,18 +70,13 @@ import Paths_hsfm
     getDataFileName
   )
 import Prelude hiding(readFile)
-import System.INotify
+import System.INotify.ByteString
   (
     addWatch
   , initINotify
   , killINotify
   , EventVariety(..)
   )
-import System.Posix.FilePath
-  (
-    pathSeparator
-  , hiddenFile
-  )
 
 
 
@@ -97,12 +84,8 @@ import System.Posix.FilePath
 newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
 newTab mygui iofmv path = do
   myview <- createMyView mygui iofmv
-  i <- notebookAppendPage (notebook mygui) (viewBox myview)
+  _ <- notebookAppendPage (notebook mygui) (viewBox myview)
        (maybe (P.fromAbs path) P.fromRel $ P.basename path)
-  mpage <- notebookGetNthPage (notebook mygui) i
-  forM_ mpage $ \page -> notebookSetTabReorderable (notebook mygui)
-                                                   page
-                                                   True
   refreshView mygui myview (Just path)
   return myview
 
@@ -321,7 +304,7 @@ refreshView mygui myview mfp =
                                                      Item)
         case ecd of
           Right dir -> return (Just $ path dir)
-          Left _    -> return (P.parseAbs $ BS.singleton pathSeparator)
+          Left _    -> return (P.parseAbs P.pathSeparator')
 
 
 -- |Refreshes the View based on the given directory.
@@ -332,9 +315,7 @@ refreshView' :: MyGUI
              -> MyView
              -> Item
              -> IO ()
-refreshView' mygui myview SymLink { sdest = d@Dir{} } =
+refreshView' mygui myview item@(DirOrSym _) = do
-  refreshView' mygui myview d
-refreshView' mygui myview item@Dir{} = do
   newRawModel  <- fileListStore item myview
   writeTVarIO (rawModel myview) newRawModel
 
@@ -411,7 +392,7 @@ constructView mygui myview = do
      item   <- treeModelGetRow rawModel' iter >>= (P.basename . path)
      if hidden
        then return True
-       else return . not . hiddenFile . P.fromRel $ item
+       else return $ not . P.hiddenFile $ item
 
   -- sorting
   sortedModel' <- treeModelSortNewWithModel filteredModel'

src/HSFM/GUI/Gtk/Utils.hs

@@ -21,10 +21,6 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 module HSFM.GUI.Gtk.Utils where
 
 
-import Control.Applicative
-  (
-    (<$>)
-  )
 import Control.Concurrent.MVar
   (
     readMVar

src/HSFM/Settings/Bookmarks.hs

@@ -0,0 +1,139 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module HSFM.Settings.Bookmarks where
+
+
+import Control.Monad
+  (
+    void
+  )
+import Data.Attoparsec.ByteString
+import qualified Data.ByteString as BS
+import Data.ByteString
+  (
+    ByteString
+  )
+import Data.Maybe
+  (
+    catMaybes
+  , fromJust
+  )
+import Data.Word8
+  (
+    _nul
+  )
+import qualified HPath as P
+import HPath
+  (
+    Abs
+  , Fn
+  , Path
+  )
+import HSFM.FileSystem.FileOperations
+import HSFM.FileSystem.FileType
+import Prelude hiding (readFile, writeFile)
+import System.Posix.Env.ByteString
+  (
+    getEnv
+  )
+
+
+
+-- |A bookmark. `bkName` is principally a description of the bookmark
+-- but must satisfy the constraints of a filename.
+data Bookmark = MkBookmark {
+    bkName :: Path Fn
+  , bkPath :: Path Abs
+} deriving (Show)
+
+
+-- |Parses bookmarks from a ByteString that has pairs of
+-- name and path. Name and path are separated by one null character
+-- and the pairs itself are separated by two null characters from
+-- each other.
+bkParser :: Parser [Bookmark]
+bkParser =
+  fmap catMaybes $ many' (fmap toBm $ bookmark <* word8 _nul <* word8 _nul)
+  where
+    toBm :: (ByteString, ByteString) -> Maybe Bookmark
+    toBm (name, path) = MkBookmark <$> P.parseFn name
+                                   <*> P.parseAbs path
+    bookmark :: Parser (ByteString, ByteString)
+    bookmark =
+      (\x y -> (BS.pack x, BS.pack y))
+      <$> many1' char
+      <* (word8 _nul)
+      <*> many1' char
+    char = satisfy (`notElem` [_nul])
+
+
+-- |Writes bookmarks to a given file.
+writeBookmarks :: [Bookmark] -> IO ()
+writeBookmarks [] = return ()
+writeBookmarks bs = do
+  bf  <- bookmarksFile
+  bfd <- bookmarksDir
+  mkdirP bfd
+  readFile getFileInfo bfd >>= (\x -> createFile x bookmarksFileName)
+  let str = foldr1 (\x y -> x `BS.append` BS.pack [_nul, _nul]
+                              `BS.append`
+                            y `BS.append` BS.pack [_nul, _nul])
+            (fmap toByteString bs)
+  file <- readFile getFileInfo bf
+  void $ writeFile file str
+    where
+    toByteString :: Bookmark -> ByteString
+    toByteString b =             (P.fromRel $ bkName b)
+                     `BS.append` BS.singleton _nul
+                     `BS.append` (P.fromAbs $ bkPath b)
+
+
+-- |Reads bookmarks from a given file.
+readBookmarks :: IO [Bookmark]
+readBookmarks = do
+  p    <- bookmarksFile
+  file <- readFile getFileInfo p
+  c    <- readFileContents file
+  case parseOnly bkParser c of
+    Left _  -> return []
+    Right x -> return x
+
+
+bookmarksDir :: IO (Path Abs)
+bookmarksDir = do
+  mhomedir  <- getEnv "HOME"
+  case mhomedir of
+    Nothing   -> ioError (userError "No valid homedir?!")
+    Just home -> do
+      phome  <- P.parseAbs home
+      reldir <- P.parseRel ".config/hsfm"
+      return $ phome P.</> reldir
+
+
+bookmarksFile :: IO (Path Abs)
+bookmarksFile = do
+  path <- bookmarksDir
+  return $ path P.</> bookmarksFileName
+
+
+bookmarksFileName :: Path Fn
+bookmarksFileName = fromJust $ P.parseFn "bookmarks"

src/HSFM/Utils/IO.hs

@@ -33,6 +33,11 @@ import Control.Concurrent.STM.TVar
   , modifyTVar
   , TVar
   )
+import Control.Monad
+  (
+    when
+  , unless
+  )
 
 
 -- |Atomically write a TVar.
@@ -44,3 +49,14 @@ writeTVarIO tvar val = atomically $ writeTVar tvar val
 modifyTVarIO :: TVar a -> (a -> a) -> IO ()
 modifyTVarIO tvar f = atomically $ modifyTVar tvar f
 
+
+-- |If the value of the first argument is True, then execute the action
+-- provided in the second argument, otherwise do nothing.
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM mb a = mb >>= (`when` a)
+
+
+-- |If the value of the first argument is False, then execute the action
+-- provided in the second argument, otherwise do nothing.
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM mb a = mb >>= (`unless` a)