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

LIB/GTK: use ByteString instead of String for

Browse Source
This commit is contained in:
Julian Ospald 2016-04-05 00:56:36 +02:00
parent af20dcf866
commit bad817d32d
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
11 changed files with 194 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitmodules vendored
View File

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

1
3rdparty/hinotify vendored Submodule

@ -0,0 +1 @@
Subproject commit 19094dd59e76e163ec27f5eb5c02b2906dc72bc1

2
3rdparty/hpath vendored

@ -1 +1 @@
Subproject commit c7229061d041a069a40149d30520e2ea40483c86
Subproject commit 148eeb619fd6d44589dae556970c623eb4a42131

5
hsfm.cabal
View File

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

31
src/HSFM/FileSystem/Errors.hs
View File

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

43
src/HSFM/FileSystem/FileOperations.hs
View File

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

54
src/HSFM/FileSystem/FileType.hs
View File

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

84
src/HSFM/GUI/Glib/GlibString.hs Normal file
View File

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

10
src/HSFM/GUI/Gtk.hs
View File

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

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

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

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

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