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

LIB/GTK: remove obsolete fullPath/fullPathS and refactor for prettiness

Browse Source
This commit is contained in:
Julian Ospald 2016-04-16 21:50:15 +02:00
parent 593a59787f
commit e2c83b3c31
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 87 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -223,13 +223,11 @@ copyDir (Rename fn)
_
= copyDir Strict from to fn
-- this branch must never get `Rename` as CopyMode
copyDir cm from@Dir{}
to@Dir{}
copyDir cm from@Dir{ path = fromp }
to@Dir{ path = top }
fn
= do
let fromp = fullPath from
top = fullPath to
destdirp = top P.</> fn
let destdirp = top P.</> fn
-- for performance, sanity checks are only done for the top dir
throwDestinationInSource fromp destdirp
throwSameFile fromp destdirp
@ -238,24 +236,25 @@ copyDir cm from@Dir{}
go cm from to fn
where
go :: CopyMode -> File a -> File a -> Path Fn -> IO ()
go cm' from'@Dir{}
to'@Dir{}
go cm' Dir{ path = fromp' }
Dir{ path = top' }
fn' = do
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fullPathS from')
createDestdir (fullPath to' P.</> fn') fmode'
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus
(P.fromAbs fromp')
createDestdir (top' P.</> fn') fmode'
destdir <- readFile (\_ -> return undefined)
(fullPath to' P.</> fn')
(top' P.</> fn')
contents <- readDirectoryContents
(\_ -> return undefined) (fullPath from')
(\_ -> return undefined) fromp'
for_ contents $ \f ->
case f of
SymLink{} -> recreateSymlink cm' f destdir
=<< (P.basename . path $ f)
Dir{} -> go cm' f destdir
=<< (P.basename . path $ f)
RegFile{} -> unsafeCopyFile Replace f destdir
=<< (P.basename . path $ f)
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' =
@ -287,11 +286,11 @@ recreateSymlink :: CopyMode
-> IO ()
recreateSymlink (Rename pn) symf@SymLink{} symdest@Dir{} _
= recreateSymlink Strict symf symdest pn
recreateSymlink cm symf@SymLink{} symdest@Dir{} fn
recreateSymlink cm SymLink{ path = sfp } Dir{ path = sdp } fn
= do
throwCantOpenDirectory $ fullPath symdest
sympoint <- readSymbolicLink (fullPathS symf)
let symname = fullPath symdest P.</> fn
throwCantOpenDirectory sdp
sympoint <- readSymbolicLink (P.fromAbs sfp)
let symname = sdp P.</> fn
case cm of
Merge -> delOld symname
Replace -> delOld symname
@ -314,13 +313,13 @@ copyFile :: CopyMode
-> IO ()
copyFile (Rename pn) from@RegFile{} to@Dir{} _
= copyFile Strict from to pn
copyFile cm from@RegFile{} to@Dir{} fn
copyFile cm from@RegFile{ path = fromp }
tod@Dir{ path = todp } fn
= do
let to' = fullPath to P.</> fn
throwCantOpenDirectory $ fullPath to
throwCantOpenDirectory . P.dirname . fullPath $ from
throwSameFile (fullPath from) to'
unsafeCopyFile cm from to fn
throwCantOpenDirectory todp
throwCantOpenDirectory . P.dirname $ fromp
throwSameFile fromp (todp P.</> fn)
unsafeCopyFile cm from tod fn
copyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
@ -335,19 +334,21 @@ unsafeCopyFile :: CopyMode
-> IO ()
unsafeCopyFile (Rename pn) from@RegFile{} to@Dir{} _
= copyFile Strict from to pn
unsafeCopyFile cm from@RegFile{} to@Dir{} fn
unsafeCopyFile cm RegFile{ path = fromp }
Dir{ path = todp } fn
= do
let to' = fullPath to P.</> fn
let to = todp P.</> fn
case cm of
Strict -> throwFileDoesExist to'
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 (fullPathS from) (P.fromAbs to'))
(void $ fallbackCopy (fullPathS from) (P.fromAbs to'))
(sendFileCopy from' to')
(void $ fallbackCopy from' to')
where
-- this is low-level stuff utilizing sendfile(2) for speed
sendFileCopy source dest =
@ -417,45 +418,43 @@ easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
-- |Deletes a symlink, which can either point to a file or directory.
deleteSymlink :: File a -> IO ()
deleteSymlink f@SymLink{}
= removeLink (P.toFilePath . fullPath $ f)
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 f@RegFile{}
= removeLink (P.toFilePath . fullPath $ f)
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 f@Dir{}
= removeDirectory (P.toFilePath . fullPath $ f)
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{} = do
let fp = fullPath f'
throwCantOpenDirectory fp
deleteDirRecursive f'@Dir{ path = fp' } = do
throwCantOpenDirectory fp'
go f'
where
go :: File a -> IO ()
go f@Dir{} = do
let fp = fullPath f
go Dir{ path = fp } = do
files <- readDirectoryContents
(\_ -> return undefined) fp
for_ files $ \file ->
case file of
SymLink{} -> deleteSymlink file
Dir{} -> go file
RegFile{} -> removeLink (P.toFilePath . fullPath $ file)
RegFile{ path = rfp }
-> P.withAbsPath rfp removeLink
_ -> throw $ FileDoesExist
(P.toFilePath . fullPath
$ file)
(P.toFilePath . path $ file)
removeDirectory . P.toFilePath $ fp
go _ = throw $ InvalidOperation "wrong input type"
deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"
@ -485,17 +484,22 @@ easyDelete _ = throw $ InvalidOperation "wrong input type"
openFile :: File a
-> IO ProcessID
openFile f =
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fullPathS f] Nothing
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 prog@RegFile{} args
= SPP.forkProcess $ SPP.executeFile (fullPathS prog) True args Nothing
executeFile prog@SymLink{ sdest = RegFile{} } args
= SPP.forkProcess $ SPP.executeFile (fullPathS prog) True args Nothing
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"
@ -509,7 +513,7 @@ executeFile _ _ = throw $ InvalidOperation "wrong input type"
-- |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 = fullPath td P.</> fn
let fullp = path td P.</> fn
throwFileDoesExist fullp
fd <- SPI.createFile (P.fromAbs fullp) newFilePerms
SPI.closeFd fd
@ -519,7 +523,7 @@ 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 = fullPath td P.</> fn
let fullp = path td P.</> fn
throwDirDoesExist fullp
createDirectory (P.fromAbs fullp) newFilePerms
createDir _ _ = throw $ InvalidOperation "wrong input type"
@ -535,7 +539,7 @@ createDir _ _ = throw $ InvalidOperation "wrong input type"
-- |Rename a given file with the provided filename.
renameFile :: File a -> Path Fn -> IO ()
renameFile af fn = do
let fromf = fullPath af
let fromf = path af
tof = (P.dirname . path $ af) P.</> fn
throwFileDoesExist tof
throwSameFile fromf tof
@ -551,10 +555,10 @@ moveFile :: CopyMode
moveFile (Rename pn) from to@Dir{} _ =
moveFile Strict from to pn
moveFile cm from to@Dir{} fn = do
let from' = fullPath from
froms' = fullPathS from
to' = fullPath to P.</> fn
tos' = P.fromAbs (fullPath to P.</> fn)
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'

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

@ -346,7 +346,7 @@ getContents :: (Path Abs -> IO a)
-> File FileInfo
-> IO [File a]
getContents ff (DirOrSym af)
= readDirectoryContents ff (fullPath af)
= readDirectoryContents ff (path af)
getContents _ _ = return []
@ -464,12 +464,13 @@ isSocketC _ = False
-- |Gets all filenames of the given directory. This excludes "." and "..".
getDirsFiles :: Path Abs -- ^ dir to read
-> IO [Path Abs]
getDirsFiles fp =
rethrowErrnoAs [eACCES] (Can'tOpenDirectory . P.fromAbs $ fp)
getDirsFiles p =
P.withAbsPath p $ \fp ->
rethrowErrnoAs [eACCES] (Can'tOpenDirectory fp)
$ return
. catMaybes
. fmap (\x -> (P.</>) fp <$> (parseMaybe . snd $ x))
=<< getDirectoryContents (P.toFilePath fp)
. fmap (\x -> (P.</>) p <$> (parseMaybe . snd $ x))
=<< getDirectoryContents fp
where
parseMaybe :: ByteString -> Maybe (Path Fn)
parseMaybe = P.parseFn
@ -543,6 +544,10 @@ 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
@ -555,16 +560,6 @@ getFreeVar (Socket _ d) = Just d
getFreeVar _ = Nothing
-- |Get the full path of the file.
fullPath :: File a -> Path Abs
fullPath f = path f
-- |Get the full path of the file, converted to a `FilePath`.
fullPathS :: File a -> ByteString
fullPathS = P.fromAbs . fullPath
-- |Pack the modification time into a string.
packModTime :: File FileInfo
-> String

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

@ -239,7 +239,7 @@ open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
DirOrSym r -> do
nv <- readFile getFileInfo $ fullPath r
nv <- readFile getFileInfo $ path r
refreshView' mygui myview nv
r ->
void $ openFile r
@ -263,7 +263,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 \"" ++ P.fpToString (fullPathS item) ++ "\"?"
let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?"
withConfirmationDialog cmsg
$ easyDelete item
-- this throws on the first error that occurs
@ -279,9 +279,9 @@ del _ _ _ = withErrorDialog
-- |Initializes a file move operation.
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
moveInit items@(_:_) mygui myview = do
writeTVarIO (operationBuffer myview) (FMove . MP1 . map fullPath $ items)
writeTVarIO (operationBuffer myview) (FMove . MP1 . map path $ items)
let sbmsg = case items of
(item:[]) -> "Move buffer: " ++ P.fpToString (fullPathS item)
(item:[]) -> "Move buffer: " ++ getFPasStr item
_ -> "Move buffer: " ++ (show . length $ items)
++ " items"
popStatusbar mygui
@ -293,9 +293,9 @@ moveInit _ _ _ = withErrorDialog
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
copyInit items@(_:_) mygui myview = do
writeTVarIO (operationBuffer myview) (FCopy . CP1 . map fullPath $ items)
writeTVarIO (operationBuffer myview) (FCopy . CP1 . map path $ items)
let sbmsg = case items of
(item:[]) -> "Copy buffer: " ++ P.fpToString (fullPathS item)
(item:[]) -> "Copy buffer: " ++ getFPasStr item
_ -> "Copy buffer: " ++ (show . length $ items)
++ " items"
popStatusbar mygui
@ -309,7 +309,7 @@ copyInit _ _ _ = withErrorDialog
operationFinal :: MyGUI -> MyView -> IO ()
operationFinal _ myview = withErrorDialog $ do
op <- readTVarIO (operationBuffer myview)
cdir <- fullPath <$> getCurrentDir myview
cdir <- path <$> getCurrentDir myview
case op of
FMove (MP1 s) -> do
let cmsg = "Really move " ++ imsg s
@ -355,7 +355,7 @@ renameF [item] _ _ = withErrorDialog $ do
mfn <- textInputDialog "Enter new file name"
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ P.fpToString (fullPathS item)
let cmsg = "Really rename \"" ++ getFPasStr item
++ "\"" ++ " to \""
++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
P.</> fn) ++ "\"?"

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

@ -228,7 +228,7 @@ refreshView mygui myview mfp =
ecd <- try (getCurrentDir myview) :: IO (Either SomeException
Item)
case ecd of
Right dir -> return (Just $ fullPath dir)
Right dir -> return (Just $ path dir)
Left _ -> return (P.parseAbs "/")