diff --git a/.gitmodules b/.gitmodules index 4afda74..b71b5e9 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,6 @@ [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 diff --git a/3rdparty/hinotify b/3rdparty/hinotify new file mode 160000 index 0000000..19094dd --- /dev/null +++ b/3rdparty/hinotify @@ -0,0 +1 @@ +Subproject commit 19094dd59e76e163ec27f5eb5c02b2906dc72bc1 diff --git a/3rdparty/hpath b/3rdparty/hpath index c722906..148eeb6 160000 --- a/3rdparty/hpath +++ b/3rdparty/hpath @@ -1 +1 @@ -Subproject commit c7229061d041a069a40149d30520e2ea40483c86 +Subproject commit 148eeb619fd6d44589dae556970c623eb4a42131 diff --git a/hsfm.cabal b/hsfm.cabal index 93c8690..8c5909f 100644 --- a/hsfm.cabal +++ b/hsfm.cabal @@ -61,6 +61,7 @@ library executable hsfm-gtk main-is: HSFM/GUI/Gtk.hs other-modules: + HSFM.GUI.Glib.GlibString HSFM.GUI.Gtk.Callbacks HSFM.GUI.Gtk.Data HSFM.GUI.Gtk.Dialogs @@ -77,6 +78,7 @@ executable hsfm-gtk bytestring, containers, data-default, + encoding, filepath >= 1.3.0.0, glib >= 0.13, gtk3 >= 0.14.1, @@ -91,7 +93,8 @@ executable hsfm-gtk time >= 1.4.2, transformers, unix, - unix-bytestring + unix-bytestring, + word8 hs-source-dirs: src default-language: Haskell2010 Default-Extensions: RecordWildCards diff --git a/src/HSFM/FileSystem/Errors.hs b/src/HSFM/FileSystem/Errors.hs index 22e30cd..2622916 100644 --- a/src/HSFM/FileSystem/Errors.hs +++ b/src/HSFM/FileSystem/Errors.hs @@ -16,8 +16,8 @@ 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 #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK ignore-exports #-} -- |Provides error handling. module HSFM.FileSystem.Errors where @@ -42,17 +42,13 @@ import HPath , Path ) import HSFM.Utils.IO -import System.FilePath - ( - equalFilePath - ) import System.IO.Error ( catchIOError ) -import qualified System.Posix.Files as PF -import qualified System.Posix.Directory as PFD +import qualified System.Posix.Files.ByteString as PF +import qualified System.Posix.Directory.ByteString as PFD data FmIOException = FileDoesNotExist String @@ -84,22 +80,26 @@ instance Exception FmIOException throwFileDoesExist :: Path Abs -> IO () throwFileDoesExist fp = - whenM (doesFileExist fp) (throw $ FileDoesExist $ P.fromAbs fp) + whenM (doesFileExist fp) (throw . FileDoesExist + . P.fpToString . P.fromAbs $ fp) throwDirDoesExist :: Path Abs -> IO () throwDirDoesExist fp = - whenM (doesDirectoryExist fp) (throw $ DirDoesExist $ P.fromAbs fp) + whenM (doesDirectoryExist fp) (throw . DirDoesExist + . P.fpToString . P.fromAbs $ fp) throwFileDoesNotExist :: Path Abs -> IO () throwFileDoesNotExist fp = - whenM (doesFileExist fp) (throw $ FileDoesExist $ P.fromAbs fp) + whenM (doesFileExist fp) (throw . FileDoesExist + . P.fpToString . P.fromAbs $ fp) throwDirDoesNotExist :: Path Abs -> IO () throwDirDoesNotExist fp = - whenM (doesDirectoryExist fp) (throw $ DirDoesExist $ P.fromAbs fp) + whenM (doesDirectoryExist fp) (throw . DirDoesExist + . P.fpToString . P.fromAbs $ fp) throwSameFile :: Path Abs -- ^ will be canonicalized @@ -113,7 +113,8 @@ throwSameFile fp1 fp2 = do (\_ -> fmap P.fromAbs $ (P. P.basename fp2) <$> (P.canonicalizePath $ P.dirname fp2)) - when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2') + when (P.equalFilePath fp1' fp2') (throw $ SameFile (P.fpToString fp1') + (P.fpToString fp2')) -- |Checks whether the destination directory is contained @@ -133,7 +134,8 @@ throwDestinationInSource source dest = do 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)) + (throw $ DestinationInSource (P.fpToString $ P.fromAbs dest) + (P.fpToString $ P.fromAbs source)) -- |Checks if the given file exists and is not a directory. This follows @@ -166,7 +168,8 @@ canOpenDirectory fp = throwCantOpenDirectory :: Path Abs -> IO () throwCantOpenDirectory fp = - unlessM (canOpenDirectory fp) (throw $ Can'tOpenDirectory $ P.fromAbs fp) + unlessM (canOpenDirectory fp) + (throw . Can'tOpenDirectory . show . P.fromAbs $ fp) diff --git a/src/HSFM/FileSystem/FileOperations.hs b/src/HSFM/FileSystem/FileOperations.hs index b1862e9..4fb77fc 100644 --- a/src/HSFM/FileSystem/FileOperations.hs +++ b/src/HSFM/FileSystem/FileOperations.hs @@ -16,8 +16,9 @@ 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 #-} +{-# 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 @@ -38,6 +39,10 @@ import Control.Monad ( unless ) +import Data.ByteString + ( + ByteString + ) import Data.Foldable ( for_ @@ -55,12 +60,12 @@ import qualified HPath as P import HSFM.FileSystem.Errors import HSFM.FileSystem.FileType import HSFM.Utils.IO -import System.Posix.Directory +import System.Posix.Directory.ByteString ( createDirectory , removeDirectory ) -import System.Posix.Files +import System.Posix.Files.ByteString ( createSymbolicLink , fileMode @@ -79,22 +84,17 @@ import System.Posix.Files , unionFileModes , removeLink ) -import qualified "unix" System.Posix.IO as SPI +import qualified "unix" System.Posix.IO.ByteString as SPI import "unix-bytestring" System.Posix.IO.ByteString ( fdWrite ) +import qualified System.Posix.Process.ByteString as SPP import System.Posix.Types ( FileMode + , ProcessID ) -import System.Process - ( - spawnProcess - , ProcessHandle - ) - -import qualified Data.ByteString as BS @@ -110,7 +110,7 @@ data FileOperation = FCopy Copy | FMove Move | FDelete (AnchoredFile FileInfo) | FOpen (AnchoredFile FileInfo) - | FExecute (AnchoredFile FileInfo) [String] + | FExecute (AnchoredFile FileInfo) [ByteString] | None @@ -264,9 +264,9 @@ copyFile cm from@(_ :/ RegFile {}) to@(_ :/ Dir {}) fn throwCantOpenDirectory . P.dirname . fullPath $ from throwCantOpenDirectory . fullPath $ to fromFstatus <- getSymbolicLinkStatus (P.fromAbs from') - fromContent <- BS.readFile (P.fromAbs from') + fromContent <- readFileContents from fd <- SPI.createFile (P.fromAbs to') - (System.Posix.Files.fileMode fromFstatus) + (System.Posix.Files.ByteString.fileMode fromFstatus) _ <- onException (fdWrite fd fromContent) (SPI.closeFd fd) SPI.closeFd fd @@ -335,7 +335,9 @@ deleteDirRecursive f@(_ :/ Dir {}) = do (_ :/ SymLink {}) -> deleteSymlink file (_ :/ Dir {}) -> deleteDirRecursive file (_ :/ RegFile {}) -> removeLink (P.toFilePath . fullPath $ file) - _ -> throw $ FileDoesExist (P.toFilePath . fullPath $ file) + _ -> throw $ FileDoesExist + (P.fpToString . P.toFilePath . fullPath + $ file) removeDirectory . P.toFilePath $ fp deleteDirRecursive _ = throw $ InvalidOperation "wrong input type" @@ -361,18 +363,19 @@ easyDelete _ = throw $ InvalidOperation "wrong input type" -- |Opens a file appropriately by invoking xdg-open. openFile :: AnchoredFile a - -> IO ProcessHandle + -> IO ProcessID openFile AFileInvFN = throw InvalidFileName -openFile f = spawnProcess "xdg-open" [fullPathS f] +openFile f = + SPP.forkProcess $ SPP.executeFile "xdg-open" True [fullPathS f] Nothing -- |Executes a program with the given arguments. executeFile :: AnchoredFile FileInfo -- ^ program - -> [String] -- ^ arguments - -> IO ProcessHandle + -> [ByteString] -- ^ arguments + -> IO ProcessID executeFile AFileInvFN _ = throw InvalidFileName executeFile prog@(_ :/ RegFile {}) args - = spawnProcess (fullPathS prog) args + = SPP.forkProcess $ SPP.executeFile (fullPathS prog) True args Nothing executeFile _ _ = throw $ InvalidOperation "wrong input type" diff --git a/src/HSFM/FileSystem/FileType.hs b/src/HSFM/FileSystem/FileType.hs index d4bf82f..a378a40 100644 --- a/src/HSFM/FileSystem/FileType.hs +++ b/src/HSFM/FileSystem/FileType.hs @@ -16,6 +16,8 @@ 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 data types for representing directories/files @@ -30,6 +32,7 @@ module HSFM.FileSystem.FileType where import Control.Exception ( handle + , bracket ) import Control.Exception.Base ( @@ -40,11 +43,8 @@ import Control.Monad.State.Lazy ( ) +import Data.ByteString(ByteString) import Data.Default -import Data.List - ( - isPrefixOf - ) import Data.Time.Clock.POSIX ( POSIXTime @@ -60,12 +60,6 @@ import HPath ) import qualified HPath as P import HSFM.Utils.MyPrelude -import System.FilePath - ( - isAbsolute - , pathSeparator - , () - ) import System.IO.Error ( ioeGetErrorType @@ -83,8 +77,13 @@ import System.Posix.Types , UserID ) -import qualified System.Posix.Files as PF -import qualified System.Posix.Directory as PFD +import qualified Data.ByteString as B +import qualified System.Posix.Directory.ByteString as PFD +import qualified System.Posix.Files.ByteString as PF +import qualified "unix" System.Posix.IO.ByteString as PIO +import qualified "unix-bytestring" System.Posix.IO.ByteString as PIOB + + @@ -124,7 +123,7 @@ data File a = , fvar :: a , sdest :: AnchoredFile a -- ^ symlink madness, -- we need to know where it points to - , rawdest :: FilePath + , rawdest :: ByteString } | BlockDev { name :: Path Fn @@ -250,7 +249,7 @@ invalidFileName :: Path Fn -> (Bool, Path Fn) invalidFileName p@(Path "") = (True, p) invalidFileName p@(Path ".") = (True, p) invalidFileName p@(Path "..") = (True, p) -invalidFileName p = (elem pathSeparator (P.fromRel p), p) +invalidFileName p = (B.elem P.pathSeparator (P.fromRel p), p) -- |Matches on invalid filesnames, such as ".", ".." and anything @@ -409,7 +408,7 @@ readWith ff p = do -- watch out, we call from 'filepath' here, but it is safe -- TODO: could it happen that too many '..' lead -- to something like '/' after normalization? - let sfp = if isAbsolute x then x else (P.fromAbs bd') x + let sfp = (P.fromAbs bd') `P.combine` x rsfp <- P.realPath sfp readWith ff =<< P.parseAbs rsfp return $ SymLink fn' fv resolvedSyml x @@ -511,6 +510,26 @@ comparingConstr t t' = compare (name t) (name t') + --------------------------- + --[ LOW LEVEL FUNCTIONS ]-- + --------------------------- + + +-- |Follows symbolic links. +readFileContents :: AnchoredFile a -> IO ByteString +readFileContents af@(_ :/ RegFile{}) = + bracket (PIO.openFd f PIO.ReadOnly Nothing PIO.defaultFileFlags) + PIO.closeFd + $ \fd -> do + filesz <- fmap PF.fileSize $ PF.getFdStatus fd + PIOB.fdRead fd ((fromIntegral filesz `max` 0) + 1) + where + f = fullPathS af +readFileContents _ = return B.empty + + + + --------------- --[ HELPERS ]-- --------------- @@ -684,7 +703,7 @@ isBrokenSymlink _ = False hiddenFile :: Path Fn -> Bool hiddenFile (Path ".") = False hiddenFile (Path "..") = False -hiddenFile p = "." `isPrefixOf` (P.fromRel p) +hiddenFile p = "." `B.isPrefixOf` (P.fromRel p) -- |Apply a function on the free variable. If there is no free variable @@ -711,7 +730,7 @@ fullPath (bp :/ f) = bp P. name f -- |Get the full path of the file, converted to a `FilePath`. -fullPathS :: AnchoredFile a -> FilePath +fullPathS :: AnchoredFile a -> ByteString fullPathS = P.fromAbs . fullPath @@ -728,6 +747,7 @@ packPermissions :: File FileInfo -> String packPermissions dt = fromFreeVar (pStr . fileMode) dt where + pStr :: FileMode -> String pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr where typeModeStr = case dt of diff --git a/src/HSFM/GUI/Glib/GlibString.hs b/src/HSFM/GUI/Glib/GlibString.hs new file mode 100644 index 0000000..ea51124 --- /dev/null +++ b/src/HSFM/GUI/Glib/GlibString.hs @@ -0,0 +1,84 @@ +{-- +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.GUI.Glib.GlibString where + + +import qualified Data.ByteString as BS +import Data.Encoding + ( + decodeStrictByteString + ) +import Data.Encoding.UTF8 + ( + UTF8(..) + ) +import Data.Word8 + ( + _percent + ) +import Foreign.C.String + ( + CStringLen + , CString + ) +import Foreign.C.Types + ( + CSize(..) + ) +import Foreign.Marshal.Utils + ( + maybePeek + ) +import Foreign.Ptr + ( + nullPtr + , plusPtr + ) +import System.Glib.UTFString + + + +-- TODO: move this to its own module +instance GlibString BS.ByteString where + withUTFString = BS.useAsCString + withUTFStringLen s f = BS.useAsCStringLen s (f . noNullPtrs) + peekUTFString s = do + len <- c_strlen s + BS.packCStringLen (s, fromIntegral len) + maybePeekUTFString = maybePeek peekUTFString + peekUTFStringLen = BS.packCStringLen + newUTFString = newUTFString . decodeStrictByteString UTF8 + newUTFStringLen = newUTFStringLen . decodeStrictByteString UTF8 + genUTFOfs = genUTFOfs . decodeStrictByteString UTF8 + stringLength = BS.length + unPrintf s = BS.intercalate "%%" (BS.split _percent s) + + +foreign import ccall unsafe "string.h strlen" c_strlen + :: CString -> IO CSize + + +noNullPtrs :: CStringLen -> CStringLen +noNullPtrs (p, 0) | p == nullPtr = (plusPtr p 1, 0) +noNullPtrs s = s + diff --git a/src/HSFM/GUI/Gtk.hs b/src/HSFM/GUI/Gtk.hs index 3b502cb..d818a3f 100644 --- a/src/HSFM/GUI/Gtk.hs +++ b/src/HSFM/GUI/Gtk.hs @@ -16,6 +16,7 @@ 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 Main where @@ -35,24 +36,21 @@ import Safe ( headDef ) -import System.Environment - ( - getArgs - ) +import qualified System.Posix.Env.ByteString as SPE main :: IO () main = do _ <- initGUI - args <- getArgs + args <- SPE.getArgs mygui <- createMyGUI myview <- createMyView mygui createTreeView let mdir = fromMaybe (fromJust $ P.parseAbs "/") - (P.parseAbs $ headDef "/" args) + (P.parseAbs . headDef "/" $ args) refreshView mygui myview (Just $ mdir) widgetShowAll (rootWin mygui) diff --git a/src/HSFM/GUI/Gtk/Callbacks.hs b/src/HSFM/GUI/Gtk/Callbacks.hs index 0068434..1d85967 100644 --- a/src/HSFM/GUI/Gtk/Callbacks.hs +++ b/src/HSFM/GUI/Gtk/Callbacks.hs @@ -236,7 +236,7 @@ execute _ _ _ = withErrorDialog -- |Supposed to be used with 'withRows'. Deletes a file or directory. del :: [Item] -> MyGUI -> MyView -> IO () del [item] _ _ = withErrorDialog $ do - let cmsg = "Really delete \"" ++ fullPathS item ++ "\"?" + let cmsg = "Really delete \"" ++ P.fpToString (fullPathS item) ++ "\"?" withConfirmationDialog cmsg $ easyDelete item -- this throws on the first error that occurs @@ -253,7 +253,7 @@ del _ _ _ = withErrorDialog moveInit :: [Item] -> MyGUI -> MyView -> IO () moveInit [item] mygui myview = do writeTVarIO (operationBuffer myview) (FMove . MP1 $ item) - let sbmsg = "Move buffer: " ++ fullPathS item + let sbmsg = "Move buffer: " ++ P.fpToString (fullPathS item) popStatusbar mygui void $ pushStatusBar mygui sbmsg moveInit _ _ _ = withErrorDialog @@ -264,7 +264,7 @@ moveInit _ _ _ = withErrorDialog copyInit :: [Item] -> MyGUI -> MyView -> IO () copyInit [item] mygui myview = do writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item) - let sbmsg = "Copy buffer: " ++ fullPathS item + let sbmsg = "Copy buffer: " ++ P.fpToString (fullPathS item) popStatusbar mygui void $ pushStatusBar mygui sbmsg copyInit _ _ _ = withErrorDialog @@ -279,14 +279,16 @@ operationFinal _ myview = withErrorDialog $ do cdir <- getCurrentDir myview case op of FMove (MP1 s) -> do - let cmsg = "Really move \"" ++ fullPathS s - ++ "\"" ++ " to \"" ++ fullPathS cdir ++ "\"?" + let cmsg = "Really move \"" ++ P.fpToString (fullPathS s) + ++ "\"" ++ " to \"" ++ P.fpToString (fullPathS cdir) + ++ "\"?" withConfirmationDialog cmsg . withCopyModeDialog $ \cm -> void $ runFileOp (FMove . MC s cdir $ cm) return () FCopy (CP1 s) -> do - let cmsg = "Really copy \"" ++ fullPathS s - ++ "\"" ++ " to \"" ++ fullPathS cdir ++ "\"?" + let cmsg = "Really copy \"" ++ P.fpToString (fullPathS s) + ++ "\"" ++ " to \"" ++ P.fpToString (fullPathS cdir) + ++ "\"?" withConfirmationDialog cmsg . withCopyModeDialog $ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm) return () @@ -305,7 +307,7 @@ upDir mygui myview = withErrorDialog $ do newFile :: MyGUI -> MyView -> IO () newFile _ myview = withErrorDialog $ do mfn <- textInputDialog "Enter file name" - let pmfn = P.parseFn =<< mfn + let pmfn = P.parseFn =<< P.userStringToFP <$> mfn for_ pmfn $ \fn -> do cdir <- getCurrentDir myview createFile cdir fn @@ -314,10 +316,11 @@ newFile _ myview = withErrorDialog $ do renameF :: [Item] -> MyGUI -> MyView -> IO () renameF [item] _ _ = withErrorDialog $ do mfn <- textInputDialog "Enter new file name" - let pmfn = P.parseFn =<< mfn + let pmfn = P.parseFn =<< P.userStringToFP <$> mfn for_ pmfn $ \fn -> do - let cmsg = "Really rename \"" ++ fullPathS item - ++ "\"" ++ " to \"" ++ P.fromAbs (anchor item P. fn) ++ "\"?" + let cmsg = "Really rename \"" ++ P.fpToString (fullPathS item) + ++ "\"" ++ " to \"" + ++ P.fpToString (P.fromAbs (anchor item P. fn)) ++ "\"?" withConfirmationDialog cmsg $ HSFM.FileSystem.FileOperations.renameFile item fn renameF _ _ _ = withErrorDialog diff --git a/src/HSFM/GUI/Gtk/MyView.hs b/src/HSFM/GUI/Gtk/MyView.hs index 0d002be..82c2586 100644 --- a/src/HSFM/GUI/Gtk/MyView.hs +++ b/src/HSFM/GUI/Gtk/MyView.hs @@ -16,8 +16,10 @@ 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.GUI.Gtk.MyView where @@ -55,6 +57,7 @@ import HPath import qualified HPath as P import HSFM.FileSystem.FileOperations import HSFM.FileSystem.FileType +import HSFM.GUI.Glib.GlibString() import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Icons import HSFM.GUI.Gtk.Utils @@ -157,7 +160,7 @@ createTreeView = do -- filename column cF <- treeViewColumnNew - treeViewColumnSetTitle cF "Filename" + treeViewColumnSetTitle cF ("Filename" :: String) treeViewColumnSetResizable cF True treeViewColumnSetClickable cF True treeViewColumnSetSortColumnId cF 1 @@ -169,7 +172,7 @@ createTreeView = do -- date column cMD <- treeViewColumnNew - treeViewColumnSetTitle cMD "Date" + treeViewColumnSetTitle cMD ("Date" :: String) treeViewColumnSetResizable cMD True treeViewColumnSetClickable cMD True treeViewColumnSetSortColumnId cMD 2 @@ -179,7 +182,7 @@ createTreeView = do -- permissions column cP <- treeViewColumnNew - treeViewColumnSetTitle cP "Permission" + treeViewColumnSetTitle cP ("Permission" :: String) treeViewColumnSetResizable cP True treeViewColumnSetClickable cP True treeViewColumnSetSortColumnId cP 3